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ABSTRACT 


Temperature,  salinity,  density,  and  sound  velocity  are  the  properties  of  most  interest  to  the  physical 
oceanographer  and  acoustician.  The  Naval  Oceanographic  and  Atmospheric  Research  Laboratory  has 
produced  a  flrst-level  numerical  simulation  model  diat  can  produce  simulated  sections  of  temperature, 
salinity,  density  and  sound  velocity  in  the  vicinity  of  an  oceanic  front.  The  user  controls  the  definition 
of  the  front. 

This  technical  note  documents  the  algorithms  used  in  the  simulation  model  and  provides  a  users  guide  to 
the  programs.  Two  programs  are  documented.  The  first  program  generates  the  front,  and  the  second 
produces  plots  of  the  frontal  properties. 
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OCEAN  SIMULATION  MODEL  -  VERSION  2 
nRST  ORDER  FRONTAL  LOCATION  SIMULATION 


INTRODUCTION 

There  has  long  been  a  need  for  providing  realistic  simulations  of  frontal  properties  in  the  open  ocean. 
These  properties  include  temperature,  salinity,  density,  sound  velocity,  chemical  and  biological  tracers. 
The  computer  program  documented  in  this  technical  note  is  the  first  step  in  the  Naval  Oceanographic  and 
Atmospheric  Research  Laboratory’s  exploratory  development  simulation  program  to  provide  this  capability 
to  the  Navy  and  academic  research  community. 

This  program  was  developed  using  the  following  principles: 

1.  the  location  of  the  front  in  the  horizontal  plane  is  first  obtained, 

2.  the  depth  of  the  center  of  the  pycnocline  is  then  computed, 

3.  the  three  dimensional  density  field  is  then  determined,  and 

4.  the  fields  of  temperature,  salinity,  and  tracers. 

The  algorithms  for  the  above  steps  are  first  discussed,  followed  by  a  technical  description  of  the  program, 
a  users  guide  and  finally,  full  listings  of  the  associated  program  components. 

ALGORITHMS 

ALGORITHM  FOR  THE  FRONTAL  LOCATION  IN  THE  HORIZONTAL  PLANE 

The  algorithm  for  the  first  order  front  simulation  is  based  on  the  physical  observation  that  disturbances 
along  a  front  grow  and  propagate  in  the  local  curvilinear  coordinates  of  the  front.  We  simulate  this 
behavior  by  creating  the  front  as  a  series  of  i^iproximations,  beginning  with  a  sine  wave  with  growing 
downstream  amplitude.  For  each  subsequent  approximation,  a  higher  wave  number  sine  wave  is  added 
to  the  previous  approximation  in  coordinates  ^ong  and  normal  to  the  front,  as  illustrated  in  the  figure 
below. 

The  alongstream  coordinate  is  denoted  by  (  and  the  cross-stream,  or  normal  coordinate,  is  denoted  by 
Tl- 

The  new  position  of  the  front  is  given  by 


-  y-(5)  .  . 
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lc„  =  n-th  wave  number, 

4>„  =  random  phase  of  the  n-th  wave  component, 

^  =  alongstream  coordinate. 

ALGORITHM  FOR  THE  THERMOCLINE  DEPTH 

The  depth  of  the  thermocline  ( defined  as  the  depth  of  the  maximum  Brunt-Vaisala  frequency  profile)  can 
then  be  computed  from  the  relation: 

V^h-b\h  -  -b\h^  ,  W 


where 


‘  =  the  Rossby  radius  of  deformation  =  ND^/f, 

N  =  the  maximum  Brunt-Vaisala  frequency, 

f  =  the  Coriolis  parameter, 

Dk  =  the  depth  of  the  appropriate  isopycnal  ( on  the  boundary  where  h=hk ). 

The  boundary  conditions  are  given  as  h  =  0  along  x(5,ti),  y(5,ii)  and  h-h+asy-+«»  and  h  -  h  as 
y  -  -«>,  and 

hk  =  h^  when  the  point  is  on  the  positive  side  of  the  front, 

=  h.  when  the  point  is  on  the  negative  side  of  the  front. 

This  equation  can  be  easily  solved  by  successive  over-relaxation  on  a  given  grid.  The  primary  problem 
in  implementing  the  solution  is  determining  whether  a  point  is  on  the  positive  or  negative  side  of  the  front. 

Once  the  field  of  h(x,y)  is  determined,  the  rest  of  the  density  field  can  be  filled  in  using  the  GDEM 
profile  scheme.  If  a  mixing  of  water  mass  properties  is  desired,  the  TS  curve  can  be  filled  in  as  a  mixture, 
the  proportions  being  determined  by  the  value  of  h. 
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ALGORITHM  FOR  COMPUTING  THE  DENSITY,  TEMPERATURE,  AND  SALINITY  FIELDS 


This  algorithm  is  based  on  the  assumption  of  a  constant  form  for  the  BV  profile,  advected  vertically 
according  to  the  depth  of  the  maximum.  The  resultant  temperature  and  salinities  are  then  computed  by 
assuming  temperature  and  salinity  mix  along  surfaces  of  constant  density,  the  amount  of  mixing 
determined  by  the  relative  vertical  displacement  of  the  isopycnal  from  a  reference  level. 

1 .  Locate  desired  Latitude  and  Longitude  of  the  frontal  region  and  points  on  either  side  of  the  front. 

2.  Get  To(z)  and  So(z)  profiles  from  appropriate  data  base  (Use  Levitus  5“). 

3.  Compute  Po(z)  and  No(z). 

4.  Compute  by  the  relation  =  max[No(z)]  =  No(z„,). 

5.  Compute  the  Rossby  radius  of  Deformation  using 

6.  Compute  h(x,y)  field  from  the  d^th  algorithm  as  previously  described. 

7.  Compute  N(x,y,z)  by  displacing  N(,(z)  by  h(x,y),  i.e.  N(x,y,z)  =  No(z  +  h(x,y)), 
truncating  for  z  >  0  and  extending  No(z  +  h  )=  No(-H)  when  z  +  h  <  -H. 

8.  Compute  new  density  field  p(x,y,z)  by  integrating  N(x,y,z)  fi-om  p(x,y,h=0)  =  Po  up 
down  at  each  x,y  point. 

9.  Let  T'^(p),  S^(p)  correspond  to  T,  S  as  h  -  h"^  and  T(p),  S  (p),  correspond  to  T,  S 
as  h  -  h..  Then,  compute  T(x,y,z)  =  {(h+-h(x,y))“  T(p[x,y,z])  + 

(h(x,y)  -  h  )•  T'^(p[x,y,zJ)}/{  ^+-h)‘  +  (h-h.)*}  and  similarly  for  S. 

10.  Use  the  values  of  T,S  to  check  consistency  with  N{x,y,z)  and  compute  sound  speed 
profiles. 


DETAILED  ALGORITHM  FOR  T/S  "BLENDING"  ALONG  ISOPYCNALS 
(Expansion  of  Item  9  in  previous  algorithm) 


1.  Let  the  user  input  two  sets  of  (Latitude/Longitude)  pairs:  (6i,A.j)  ,i  =  1,2. 

2.  Retrieve  the  temperature  and  salinity  profiles  corresponding  to  these  locations, 

Ti(z)  =  T(0i,Xi,z),  i  =  1,2. 

3.  Compute  the  field  of  o(r,z)  and  h(r)  where  r  is  the  range  coordinate  along  the  desired  section.  [  Here, 
h(r=0)  corresponds  to  location  1  and  is  the  maximum  value  of  h  and  h(r=ra.„^)  corresponds  to 
location  2  and  is  the  minimum  value  of  h.  ] 
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4.  Determine  the  range  of  a  over  the  section,  i.e.  find  ,  =  max  (o(r,z)  V  r,z  e  section)  and 

=  min  (o(r,z)  V  r,z  e  section). 

5.  Compute  Ti(o),  i  =  1,2  for  o  6  [o^,o^]  at  uniformly  spaced  Ao.  In  order  to  interpolate  the 
temperatures  beyond  the  a  limits  at  locations  1  and  2,  extend  the  temperatures  and  salinities  by 
padding  with  the  end  values  of  z  and  extend  o  by  a  linear  extrapolation  from  the  ends.  [  That  is  at 
i  =  1  (r  =  0),  o(0,z)  =  o(0,0)  +  8jO(0,0)z  for  z  <  0  and  o(0,z)  =  o(0,4000)  +  3jO(0,4000)(z- 
4000)  for  z  >  4000  m,  and  similarly  for  i  =  2  (r  =  r^).] 

6.  Compute  T(r,o)  by  the  following  method: 

(  h,  -  h(r)  )•  T,(o)  +  (  h(r)  -  h,  )•  T,(o) 

T(r,o)  -  - w./ 

(  h,  -  h(r)  h(r)  -  h,  )• 

where  a  is  a  user  selected  exponent.  (Default  ==  1). 

7.  From  the  relation  a  =  o(r,z),  compute  z  =  z(r,o).  Use  this  relation  to  map  T(r,o)  -  T(r,z). 

8.  Repeat  (or  compute  concurrently)  the  processes  in  5-7  for  salinity  to  get  the  field  of  S(r,z). 

8a.  A  new  field  of  a(r,z)  is  recomputed  from  the  blended  T(r,z)  and  S(r,z)  fields  and  it  is  ensured  that 
o  is  a  nondecreasing  function  of  depth  (i.e.,  stable  stratification  everywhere).  If  it  is  not,  the  depths 
are  sorted  to  ensure  increasing  a  and  the  temperatures  and  salinities  carried  along  with  the  sort.  This 
checking  is  optional  at  the  user’s  discretion. 

9.  Compute  the  field  of  sound  velocity  c(r,z). 
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PROGRAM  FSM  -  FRONT  SIMULATION  MODELING 


OPERATING  INSTRUCTIONS; 

Control  File 

Upon  entry  into  program  FSM,  the  user  is  prompted  to  enter  a  control  file  (CF)  name.  The  control  file 
specified  by  the  user  will  be  checked  for  existence.  A  new  control  file  will  be  allocated  if  the  file  does 
exist.  All  the  processing  parameters  stored  in  the  control  file  are  also  initialized  to  default  values.  This 
control  file  is  used  to  store  input  and  output  file  names,  processing  parameters  and  other  data  output  by 
program  FSM,  such  as:  the  x,y  coordinates  of  the  front  curve  generated  by  directive  FRNT,  the  computed 
temperature,  salinity,  density,  and  frequency  profiles  generated  by  directive  TS,  etc.  The  structure  of  the 
control  file  is  described  in  detail  later  in  this  section. 

Directives:  Overview 

Program  FSM  includes  13  directives.  Once  the  name  of  the  control  file  is  entered,  the  user  may  execute 
any  of  these  directives.  Directive  LD  lists  the  names  and  the  description  of  the  directives.  Directive  SF 
allows  the  user  to  set  the  names  for  the  files  required  by  directives  such  as:  HELM,  TS,  SIG  and  SV  to 
use  as  input  and  output.  Directive  IN  initializes  all  the  processing  parameters  required  by  directives  such 
as:  FRNT,  HELM,  TS,  and  SV  to  start  the  operations.  Directive  SP  allows  the  user  to  set  processing 
parameters  to  desired  values. 

Generating  the  Front  Position 

Directive  FRNT  uses  the  current  clock  time  as  initial  seed  to  call  the  intrinsic  random  number  generator 
(RAN)  to  generate  a  front  curve.  The  number  of  points  for  the  front  curve  is  defined  by  the  parameter 
NPTS.  The  x,y  coordinates  of  the  points  constituting  the  front  curve  are  stored  in  the  control  file. 

Thermocline  Depth  Generation 

Once  the  front  curve  is  generated,  the  user  may  execute  directive  HELM  to  start  the  Helmholtz  equation 
solver  process.  This  directive  first  rescales  the  x,y  points  of  the  front  curve  to  fit  in  a  640  x  480  gridded 
space.  Value  1  is  assigned  to  all  the  pixels  above  the  curve;  value  -1  is  assigned  to  all  the  pixels  below 
the  curve  and  value  0  is  assigned  to  the  pixels  along  the  curve.  This  gridded  matrix  is  also  stored  in  the 
control  file  and  used  as  a  mask  for  the  directive  to  perform  the  HELM  computation  process.  The  final 
output  from  the  HELM  process  is  stored  into  an  external  file.  The  internal  usage  name  for  this  file  is 
named  HMF.  The  HELM  process  actually  involves  iterative  computations.  The  number  of  iterations 
required  is  defined  by  the  param^er  ITER.  Therefore,  the  process  can  potentially  be  very  time  consuming 
if  foe  param^er  ITER  is  set  to  a  large  number.  Directive  RES  was  designed  to  allow  foe  user  to  resume 
foe  HELM  operation  from  where  it  was  terminated  previously. 
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Temperature/Salinity  Field  Generation 


Before  directive  TS  is  executed,  the  user  should  use  directive  SF  to  specify  the  name  and  the  location  of 
the  Levitus  database  file  (DBF)  as  input.  In  order  to  read  the  temperature  and  salinity  data  for  the  desired 
location  from  the  DBF  file,  the  parameters  LAT(itude)  and  LONG(itude)  should  also  be  set  previously 
by  directive  SP.  After  the  temperature  and  salinity  data  are  read  in  from  the  DBF  file,  directive  TS  will 
interpolate  these  two  sets  of  data  with  evenly  spaced  depths  ranging  from  0  to  4000  m.  The  depth 
increment  is  defined  by  the  parameter  IZ  and  must  be  evenly  divisible  by  the  maximum  depth  4000  m. 
After  the  interpolation  is  done,  the  density  and  frequency  values  at  these  depth  locations  are  computed. 
The  data,  including  depth,  temperature,  salinity,  density  and  frequency  values,  are  then  stored  into  the 
control  file. 

Density  Field  Recomputation 

Directive  SIG  requires  the  output  from  directives  HELM  and  TS  as  input.  In  addition,  the  user  is  required 
to  specify  two  end  points  defining  the  section  of  interest  in  the  HMF  file  to  compute  a  new  integrated 
sigma  (density)  field.  The  output,  sigma  field,  is  stored  into  an  external  file  with  usage  name  SFF. 

Sound  Velocity  Field  Generation 

Directive  SV  requires  the  output  from  the  directives  HELM  and  SIG  as  input.  The  user  is  also  required 
to  specify  two  sets  of  latitude  and  longitude  for  the  directive  to  read  the  temperature  and  salinity  data  from 
the  DBF  file.  Based  upon  the  input  data,  directive  SV  computes  blended  temperature  and  salinity  values. 
The  blended  temperature  and  salinity  data  may  then  be  used  to  compute  sound  velocity  values.  The 
directive  SV  allows  the  user  to  select  at  least  one  of  these  computed  data  sets,  blended  temperature, 
blended  salinity,  and  sound  velocity,  to  be  output  to  an  external  file.  The  usage  names  for  these  three 
output  files  are  TF,  SF,  and  SVF,  respectively.  The  user  should  use  the  directive  SF  to  selectively  define 
these  output  file  names  before  this  directive  SV  is  executed.  Notice  that  all  the  files  output  by  program 
FSM  including:  QMF,  SSF,  TF,  SF,  and  SVF  are  checked  for  existence. 

Program  FSM  will  create  a  new  file  and  write  the  output  to  the  file  if  it  does  not  exist,  otherwise  program 
FSM  will  write  the  output  over  to  the  existing  file. 


FSM  DIRECTIVES 

DIRECTIVE  DESCRIPTION 

LD  -  List  program  main  directives 
SF  -  Set/list  external  files  to  input/output 
IN  -  Initialize  processing  parameters  to  default  values 
SP  -  Set  processing  param^ers 
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FRNT  -  Generate  front  curve 


LIST  -  List  x,y  coordinates  of  front  curve 
HELM  -  Apply  Helmholtz  equation  solver 
RES  -  Resume  Helmholtz  equation  solver 

TS  -  Generate  temperature,  salinity,  density,  and  frequency  profiles 

LP  -  List  temperature,  salinity,  density,  and  frequency  profiles 

SIG  -  Generate  integrated  sigma  field 

SV  -  Generate  sound  velocity,  blended  temperature,  or  blended 
salinity  output 

END  -  End  the  program 
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FSM  PARAMETERS 


PARAMETERS  DESCRIPTION 

The  following  parameters  are  required  by  the  directive  FRNT: 

NPTS  -  Number  of  points  used  for  front  curve  (default  to  5000) 

LM  -  Number  of  points  (+/-)  to  sample  (default  to  10) 

RLP  -  Ripple  power  (default  to  2.0) 

ITER  -  Number  of  iterations  to  generate  front  curve  (default  to  20) 

The  following  parameters  are  required  by  the  directive  HELM: 

ALFA  -  Relaxation  coefficient  (default  to  1.7) 

BETA  -  Rossby  Deformation  Radius  (default  to  20.0) 

H  -  H  grid  spacing  (default  to  0.4) 

MAXH  -  Maximum  H  value  (default  to  100) 

MINH  -  Minimum  H  value  (default  to  -100) 

JTER  -  Number  of  iterations  for  HELM  solver  (default  to  KXX)) 

The  following  parameters  are  required  by  the  directive  TS: 

LAT  -  Latitude  of  desired  location  in  degrees  (default  to  30) 

LONG  -  Longitude  of  desired  location  in  degrees  (default  to  -70) 

IZ  -  Depth  increment  (default  to  10) 

The  following  parameters  are  required  by  the  directive  SV: 

E  -  Exponent  variable  (default  to  1) 

RCF  -  Flag  indicating  necessity  of  recomputing  sigma  field  based  upon  blended  temperature  and 
salinity  (default  is  NO) 
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FSM  DESCRIPTION  AND  FORMAT  OF  CONTROL  RLE  (CF) 

The  control  file  used  by  this  program  is  a  random  access  file.  Each 
record  of  the  file  is  400  bytes  long.  The  following  items  are  stored 
in  the  control  file; 

.  Processing  parameters 

.  External  input/output  file  names  and  last  written  data  and  time 
.  The  floating-point  x,y  coordinates  of  the  points  constituting  the 
front  curve 

.  A  640  X  480  16-bit  gridded  matrix  storing  the  mask  of  the  front  curve 
.  Computed  floating-point  temperature,  salinity,  density,  and  frequency 
profiles  at  a  specific  latitude  and  longitude  location 

The  format  of  the  first  two  records  of  the  control  file  is  shown  below: 


RECORD  WORD 

TYPE 

DESCRIPTION 

1  1 

INTEGER*4 

Control  file  identifier  (56789) 

2 

ft 

Number  of  records  in  the  file 

3 

M 

Beginning  record  at  which  the  x,y 
coordinates  of  the  front  curve  is  stored 

4 

fl 

Not  used 

5 

n 

Beginning  record  at  which  the  mask  of 
the  front  curve  is  stored 

6 

n 

Not  used 

7 

M 

Beginning  record  at  which  the 
temperature,  salinity,  density  and 
frequency  profiles  are  stored 

8-10 

H 

Not  used 

11 

n 

Parameter  NPTS 

12 

n 

Parameter  LM 

13 

REAL 

Parameter  RLP 

14 

INTEGERS 

Parameter  ITER 

15-19 

n 

Not  used 

20 

m 

Number  of  points  of  the  front  curve 

21 

REAL 

Parameter  ALFA 

22 

N 

Parameter  BETA 

23 

tl 

Parameter  H 

24 

INTEGERS 

Parameter  MINH 

25 

n 

Parameter  MAXH 

26 

n 

Parameter  JTER 

27 

f* 

Not  used 

28 

f* 

Next  iteration  number 

29 

IV 

Location  at  which  the  front  curve 
crosses  left  boundary  of  the  mask 

30 

n 

Location  at  which  the  front  curve 
crosses  right  boundary  of  the  mask 
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31 

N 

Parameter  LAT 

32 

M 

Parameter  LONG 

33 

H 

Parameter  IZ 

34 

M 

Not  used 

35 

M 

MAXH  used  by  directive  TS 

36 

H 

MINH  used  by  directive  TS 

37 

N 

IZ  used  by  directive  TS 

38 

H 

Number  of  evenly  spaced  depths 

39 

M 

Location  at  which  the  maximum  frequency 
value  is  located 

40 

REAL 

Sigma  value  corresponding  to  the 
location  of  the  maximum  frequency 

41 

INTEGERS 

X  coordinate  of  the  first  end  point 

42 

N 

Y  coordinate  of  the  first  end  point 

43 

N 

X  coordinate  of  the  second  end  point 

44 

N 

Y  coordinate  of  the  second  end  point 

45 

REAL 

Minimum  sigma  value 

46 

tf 

Maximum  sigma  value 

47 

INTEGERS 

MINH  used  by  directive  SIG 

48 

ft 

MAXH  used  by  directive  SIG 

49 

ft 

IZ  used  by  directive  SIG 

50 

N 

Number  of  evenly  spaced  depths 

51 

REAL 

Parameter  E 

52 

INTEGER*4 

Parameter  RCF 

53-100 

Not  used 

1-12 

lnteger*4 

DBF  file  name 

21-26 

fi 

HMF  file  name 

27-28 

H 

HMF  file  last  written  date 

29-30 

ft 

HMF  file  last  written  time 

31-36 

tf 

SFF  file  name 

37-38 

tf 

SFF  file  last  written  date 

39-40 

tf 

SFF  file  last  written  time 

41-46 

If 

SVF  file  name 

47-48 

ft 

SVF  file  last  written  date 

49-50 

ft 

SVF  file  last  written  time 

51-56 

ft 

TF  file  name 

57-58 

ft 

TF  file  last  written  date 

59-60 

ft 

TF  file  last  written  time 

61-66 

ft 

SF  file  name 

67-68 

ft 

SF  file  last  written  date 

69-70 

ft 

SF  file  last  written  time 

71-100 

Not  used 
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FSM  INPUT/OUTPUT  FILES 


DBF:  Levitus  data  base  file  name  required  by  directives  TS  and  SV  as 
input  (default  to  [kim.modelocean.database]levitus.dat). 

File  type:  random  access. 

Record  length:  720  bytes. 

HMF:  HELM  solver  file  output  by  directives  HELM  and  RES. 

Data  type:  single-precision  output 
File  type:  random  access. 

Record  length:  1920  bytes. 

SFF:  SIGMA  field  file  output  by  directive  SIG 
Data  type:  single-precision  output 
File  type:  random  access. 

Record  length:  ((maximum  depth  4000/parameter  IZ)+ 1)*4  bytes 

SVF:  Sound  velocity  file  output  by  directive  SV. 

Data  type:  single-precision  output 
File  type:  random  access. 

Record  length:  ((maximum  d^th  40(X)/param^er  IZ)+ 1)*4  bytes 

TF:  Blended  temperature  file  output  by  directive  SV. 

Data  type:  single-precision  output 
File  type:  random  access. 

Record  length:  ((maximum  depth  4(XX)/parameter  IZ)+ 1)*4  bytes 

SF:  Blended  salinity  file  output  by  directive  SV. 

Data  type:  single-precision  output 
File  type:  random  access. 

Record  length:  ((maximum  depth  4(XX)/parameter  IZ)+ 1)*4  bytes 
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SUBROUTINES/FUNCTIONS  CALLED  BY  THE  MAIN  PROGRAM  (FSM) 


Subroutine  CKFILE 

Checks  existence  and  record  size  of  CF,  DBF,  HMF,  SFF,  SVF, 
TF  or  SF  file 

Subroutine  CLSFIL 

- 

Closes  DBF,  HMF,  SFF,  SVF,  TF  and  SF  files 

Subroutine  INPAR 

- 

Initializes  processing  parameters 

Subroutine  SETFS 

- 

Sets  file  name  for  DBF,  HMF,  SFF,  SVF,  TF  or  SF  file 

Subroutine  RUI 

- 

Reads  user’s  input  as  character  string  and  parses  it  into  Hollerith 
substrings,  integer  and  floating-point  values. 

Subroutine  SETPAR 

- 

Sets  processing  parameters 

Subroutine  RDTS 

- 

Reads  temperature  and  salinity  profiles  from  the  DBF  file  based 
upon  give  latitude  and  longitude  location 

Subroutine  DLXY 

- 

Linearly  interpolates  integer  x,y  locations  between  two  end  points 

Subroutine  SIGINT 

- 

Integrates  sigma  values 

Subroutine  LINTPL 

- 

Linearly  interpolates  y  values  within  input  given  x  limits  and 
linearly  y  values  outside  x  limits. 

Subroutine  DATIME 

- 

Gets  current  clock  time  by  calling  system  dependent  routines: 
IDATE  and  TIME 

Subroutine  INTRPL 

- 

Akima  interpolation  routine 

Function  BVFRQ 

- 

Computes  Brunt-Viisall  frequency 

Function  SVAN 

- 

Computes  sigma  value  based  upon  given  temperature,  salinity, 
pressure  and  dq)th 

Function  THETA 

- 

Computes  potential  temperature 

Function  ATG 

- 

Computes  temperature  gradient  [°C  per  decibar] 

Function  SVEL 

- 

Computes  sound  velocity  based  upon  given  temperature,  salinity 
and  depth 
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PROGRAM  FSP  -  FRONTAL  PLOTTING  PROGRAM 


FSP  OPERATING  INSTRUCTIONS: 

Program  FSP  uses  the  Display  Integrated  Software  System  and  Plotting  Language  (DISSPLA)  to  plot  a 
HMF,  SFF,  SVF,  TF,  or  SF  file  output  from  the  program  FSM  to  an  special  file  named  POPFIL.DAT. 
After  the  plot  is  generated,  the  user  may  invoke  the  postprocessor  program  DISSPLA  or  DISSIOS  to 
physically  plot  the  data  stored  in  POPFIL.DAT  to  an  external  device  such  as  a  graphic  terminal  or  a 
plotter.  For  the  description  and  the  format  of  the  files  to  be  plotted,  the  user  may  refer  to  the 
documentation  for  program  FSM. 

Initial  Prompts 

Upon  entry  into  piogram  FSP,  the  user  will  be  prompted  for  entering  the  name  of  a  control  file  (CF). 
This  control  file  should  be  the  file  previously  created  by  program  FSM  and  should  contain  the  names  of 
the  files  (HMF,  SFF,  SVF,  TF,  and  SF)  to  be  plotted,  otherwise  the  program  will  be  terminated. 

Once  the  control  file  is  checked,  program  FSP  will  automatically  put  the  user  on  the  file  selection  mode. 
The  user  should  then  select  the  file  to  be  plotted  from  one  of  the  existing  HMF,  SFF,  SVF,  TF,  and  SF 
files. 

Plotting  Parameters 

There  are  six  plotting  parameters.  Parameters  WID  and  HT  define  the  width  and  height  (X  and  Y  axes) 
of  the  plot.  Parameters  IC,  LC,  IR,  and  LR  define  an  area  of  interest  within  the  selected  file  to  be  plotted. 
After  a  file  being  selected,  these  parameters  are  automatically  set  to  default  values.  Parameters  WID  and 
HT  are  set  to  the  maximum  of  14  and  11  inches,  respectively.  Parameters  IC,  LC,  IR,  and  LR  (defining 
the  initial  and  last  columns  and  rows  of  the  area  of  interest  are  set  to  the  limits  of  the  selected  file. 
Notice  that  the  columns  and  rows  of  the  area  of  interest  are  designated  as  the  Y  and  X  axes  of  the  output 
plot,  respectively. 

Directives 

Program  FSP  includes  six  directives.  Directive  LD  lists  the  names  and  description  of  the  directives. 
Directive  IN  resets  the  plotting  parameters  to  the  default  values  mentioned  above.  Directive  SP  allows 
the  user  to  change  these  plotting  parameters  to  desired  values.  Directive  SF  puts  the  user  back  to  the  file 
selection  mode  such  that  a  new  file  may  be  selected  for  plotting.  Directive  PLOT  calls  DISSPLA  routine 
CONMAK  to  generate  contour  data  and  output  it  to  file  POPFIL.DAT.  After  this  directive  is  invoked, 
the  minimum  and  the  maximum  data  values  within  the  area  of  interest  will  be  displayed.  The  user  is  then 
asked  to  enter  a  constant  increment  value  (INCR)  for  generating  contour  lines.  Each  contour  line 
generated  will  contain  the  same  data  value.  Starting  from  the  minimum  value,  the  data  value  for  each 
contour  line  is  an  increment  of  INCR.  The  user  may  refer  to  the  DISSPLA  users  manual  for  more 
detailed  information  about  the  technique  used  by  routine  CONMAK  for  generating  contour  lines. 
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Contouring  Errors 

The  user  may  consider  to  set  the  area  of  interest  to  a  smaller  area  or  set  INCR  to  a  large  value  to  re- 
execute  directive  PLOT  if  the  error  message  "TOO  MUCH  DATA  PASSES  TO  ROUTINE  CONMAK" 
is  encountered  during  the  execution  of  this  directive. 


FSP  DIRECTIVES 
DIRECTIVE 
LD 
IN 
SP 

PLOT 

SF 

END 

FSP  PARAMETERS 
PARAMETERS 
WID 
HT 
IC 
LC 
IR 
LR 


DESCRIPTION 

List  program  main  directives 

Initialize  plotting  parameters  to  default  values 

Set  plotting  parameters 

Generate  a  plot  file  named  POPFIL.DAT 

Return  to  file  selection  mode 

End  the  program 

DESCRIPTION 

Width  of  plot  (default  to  14  inches) 

Height  of  plot  (default  to  1 1  inches) 

Initial  column  of  the  file  to  be  plotted  (default  to  1) 

Last  column  of  the  file  to  be  plotted  (default  to  record  size  of  selected  file) 
Initial  row  of  the  file  to  be  plotted  (default  to  1) 

Last  row  of  the  file  to  be  plotted  (default  to  last  record  of  selected  file) 


INPUT  HLES 

See  the  documentation  for  program  FSM  for  more  detailed  description 
about  HMF,  SFF,  SVF,  TF,  and  SV  files. 


15 


SUBROUTINES/FUNCTIONS  CALLED  BY  THE  MAIN  PROGRAM  (FSP) 

Subroutine  CKFILE  -  Checks  existence  and  record  size  of  CF,  DBF,  HMF,  SFF,  SVF, 

TF,  or  SF  file 

Subroutine  CLSFIL  -  Closes  DBF,  HMF,  SFF,  SVF,  TF,  and  SF  files 

Subroutine  RUI  -  Reads  user’s  input  as  character  string  and  parses  it  into  Hollerith, 

substrings,  integer  and  floating-point  values. 

Subroutine  SELECF  -  Selects  a  file  to  plot 

Subroutine  SETPAR  -  Sets  plotting  parameters 

Subroutine  DLXY  -  Linearly  interpolates  integer  x,y  locations  between  two  end  points 

Subroutine  DATIME  •  Get  current  clock  time  by  calling  system  dependent  routines; 

IDATE  and  TIME 

The  following  subroutines  are  called  from  DISSPLA  software  package: 

COMPRS,  PAGE,  AREA2D,  XNAME,  YNAME,  HEADIN,  GRAF,  BCOMON,  CONMAK, 
CONLIN,  CONTUR,  ENDPL  and  DONEPL 

ALGORITHM 

None 
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o  o  o  o  o  r>  o 


FSM  PROGRAM  LISTING 


PROGRAH  NAME:FSM.FOR  -  FRONT  SIMULATION  MODELING 

DATE:  JULY  2,  1990 

PROGRAMMER:  TIGER  CHENG  (SVERDRUP) 


PROGRAM  FSM 

PARAMETER  (MXFCPS=5000) 

PARAMETER  (MXCOLSs640 . MXR0US=480 , MXUS=MXCOLS*MXROUS ) 

PARAMETER  (NBPRCF^00,NUPRCF=NBPRCF/4) 

PARAMETER  (N0IRS>13) 

PARAMETER  (NUFN=6) 

PARAMETER  (MXZS>30} 

PARAMETER  (MXFS>7) 

PARAMETER  (MXVS41XROWS'»MXCOLS) 

INTEGER*2  MASK(MXCOLS,MXROWS) 

INTEGER*4  BLANKS, YES(2), IH(20), IA(10), IBUF(NUPRCF*2).JBUF(NUPRCF) 
INTEGER*4  I0IRS(NOIRS),IX(-10:NXFCPS'»10),IY(-10:MXFCPS+1O), 

*  NASK4(MXWS/2).IXS(MXVS),IYS(MXVS),INDEX(NXVS+MXVS), 

*  FILTYP(MXFS).LUS(MXFS),LUSO(MXFS) 

REAL  XDBF(180),XBUF(NUPRCF*2),ZLEV(NXZS),FA(10) 

REAL  OEP(MXVS),TEMP(MXVS).SAL(MXVS),SIG(MXVS).BVF(NXVS), 

*  DEP2(MXVS),TEMP2(NXVS),SAL2(MXVS),SIG2(NXVS).BVF2(MXVS), 

*  OEPO(MXVS ) , TEMPO<MXVS ) , SALO(MXVS } , S I GO(NXVS ) , BVFO(MXVS ) , 

*  OEP02(MXVS),TEMP02(MXVS),SAL02{MXVS),SIG02{MXVS), 

*  BVF02(NXVS),SV(NXVS) 

REAL  X<MXFCPS),Y<MXFCPS),T(MXFCPS), 

*  X1(-10:MXFCPS+10),Y1<-10:MXFCPS*10) 

REAL  OBUF(NUPRCF),AK(0:100),A(0:100),PHI(0:100) 

REAL  0(MXCOLS,MXROUS),OQ(MXWS),ETA(-1:1) 

CHARACTER*24  CFN , HMFN , SFFN . SVFN , TFN, SFN 
CHARACTER*48  0BFN,0FN 

EQUIVALENCE  ( LUS( 1 ) , LUCF ) , ( LUS(2) , LUHMF ) , (LUS(3) , LUOBF ) , 

*  (LUS(4),LUSFF),(LUS(5),LUSVF),<LUS(6),LUTF), 

*  (LUS(7),LUSF) 

EQUIVALENCE  (IBUF(1),XBUF(1),0BUF(1)).(IBUF(NWPRCF+1), JBUF(1)) 
EQUIVALENCE  (Q(1,1),QQ(1},T(1).XDBF(1)}, 

*  (QQ<MXFCPS*1),X1<-10),IX(-10)), 

*  <QQ(MXFCPS*2*22),Y1(-10),IY<-10)), 

*  (QQ<MXFCPS*3*43),X<1)),(QQ(MXFCPS*4*43),Y(1)), 

*  (QQ(MXFCPS*5^43),AK(0)),<QQ(MXFCPS*5*154),A(0)), 

*  (QQ<MXFCPS*5*255),PHI(0)) 

EQUIVALENCE  (MASK( 1 . 1 ) .NASK4( 1 ) , IXS( 1) ) , (NASK4(MXVS>1 ) , I YS( 1 ) } , 

*  (MASK4(MXVS*2*1 ),DEP< 1) ) , <MASK4(MXVS*3^1 ),TEMP( 1 ) ) , 

*  (MASK4(MXVS*4»1 ) , SAL ( 1 ) ) , (MASK4(MXVS*5*1 ) ,SI G( 1) ) , 

*  (MASK4<MXVS*6»1 ) , BVF( 1 ) ) , (MASK4<MXVS*7*1 ) ,0EP2( 1 ) ) , 

*  (MASK4(MXVS*»»1 ) , TEMP2< 1 ) ) , (MASK4(MXVS*9*1 ),SAL2( 1 ) ) , 

*  <MASK4(MXVS*10+1),SIG2<1)),(MASK4(MXVS*1U1),BVF2(1)), 

*  (MASK4(MXVS*12*1),OEPO<1)), 

*  (NASK4(MXVS*13«1),TEMPO(1)), 

*  (MASK4(MXVS*14*1 ) , SALO(  1 ) ) , <MASK4<MXVS*15+1 ) , S I GO{ 1 ) ) , 

*  (NASK4(MXVS*16«1),BVFO(1)), 

*  (NASK4(MXVS*17«1),DEP02(1)), 

*  (MASK4<MXVS*1B*1),TEMP02<1», 

*  (MASK4<NXVS*19H),SAL02<1)), 

*  (NASK4(NXVS*20»1),SI002(1)), 

*  (MASK4(MXVS*21+1 ) ,8VF02( 1 ) ) , (MASK4<MXVS*22+1 ) , SV( 1 ) ) , 

*  (NASX4(NXVS«23«1),INOEX(1)) 

DATA  IRO/5/ 

DATA  I UR/6/ 

DATA  IDCF/56789/ 

DATA  2LEV/0.,10.,20.,30,,50.,75.,100.,125.,150.,200.,250., 

*  300., 400., 500., 600. ,700.,800., 900., 1000., 1100., 

*  1200., 1300., 1400., 1500., 1750., 2000., 2500., 3000., 

*  3500., 4000./ 


17 


DATA  8LANKS/4H  / 

DATA  1D1RS/4HLD  ,4HSF  ,4HIN  ,4HSP  ,4HFRNT,4HLIST,4HHELM, 

•  4HRES  ,4HTS  ,4HLP  ,4HS1G  .4HSV  ,4HEND  / 

DATA  yES/4Hy  ,4HyES  / 

DATA  FlLTyP/4HCF  ,4HHMF  .4HDBF  ,4HSFF  ,4HSVF  .4HTF  ,4HSF  / 
DATA  LUS/3,4,7,8.9,10,11/ 

DATA  LUS0/7*-1/ 

DATA  DBFN/'DRBS:  [KIM.M00EL0CEAN.DATABASE1LEVITUS.DAT  •/ 

C 
C 

WRITE(IUR,10) 

10  FORMAT(2X.' FRONT  SIMULATION  MODELING  PROGRAM') 

WRITE(IWR,20) 

20  FORMAT (2X, 'ENTER  CONTROL  FILE  (CF)  NAME') 

CALL  RUKIRO.IUR.IH.FA.IA.NVS) 

IF(IH(1)  .EO.  BLANKS)  STOP 
URITE(CFN,30)  (IH(I),I31.NUFN) 

30  FORMAT(6A4) 

C 

C  CHECK  EXISTENCE  OF  CONTROL  FILE 
C 

CALL  CKFILE(IUR,2,CFN,1,LUS,LUSO,FILTyP,NUPRCF,IST) 

IF(IST)  40,42,50 
40  STOP 
C 

C  CHECK  FILE  IDENTIFIER  FOR  EXISTING  CONTROL  FILE 
C 

42  REAO(LUCF,REC«1)  (IBUF(I ), I>1 ,NWPRCF) 

IFdBUFd)  .NE.  IDCF)  THEN 
URITEdUR  44) 

44  FORMAT (2xi 'WRONG  CONTROL  FILE  IS  USED') 

GO  TO  900 
ENDIF 

REAO( LUCF , REC-2)  ( JBUF ( I ) , I , NUPRCF ) 

GO  TO  200 
C 

C  INITIALIZE  NEW  CONTROL  FILE 
C 

50  IBUFd)3lOCF 
IBUF(2)«2 
DO  60  I>3,NWPRCF 
IBUF<I)»0 
60  CONTINUE 

CALL  INPAR(MXFCPS,IBUF) 

WRITE(LUCF,REC»1)  <I8UF(I ), I»1,NWPRCF) 

DO  70  I>1,NWPRCF 
JBUF(I)-BLANKS 
70  CONTINUE 

REA0(DBFN,80)  ( JBUF( I ), I>1 ,12) 

80  FORMATd2A4) 

URITE(LUCF,REC>2)  (JBUF( I ),I<i1, NUPRCF) 

GO  TO  200 
C 

C  USER  SELECTS  A  DIRECTIVE  TO  PROCESS 
C 

100  WRITEdUR  130) 

130  FORMAT (2X I 'ENTER  PROGRAM  MAIN  DIRECTIVE  NAME') 

CALL  RUIdRO,IWR,IH,FA,IA,NVS) 

DO  150  IGO>1,NOIRS 

IFdH<1)  .EQ.  IDIRSdGO))  GO  TO  190 
150  CONTINUE 

WRITEdWR,160) 

160  FORMAT(2X,' INVALID  PROGRAM  MAIN  DIRECTIVE') 

GO  TO  100 
C 
C 

190  GO  TO  (200,300,400,500,600,700,800,900,1000,1100,1200,1300, 

•  9000), IGO 
C 


IS 


C  LO  -  LIST  PROGRAM  DIRECTIVES 
C 

200  WRITE(IUR.210} 

210  FORMAT ( 

*2X. ‘PROGRAM  FSM  DIRECTIVES;',/, 

*2X,‘LD  -  LIST  PROGRAM  DIRECTIVES',/, 

•2X,'SF  -  SET/LIST  EXTERNAL  FI.'.ES  TO  INPUT/OOTPUT' ,/, 

*2X,'IN  •  INITIALIZE  PROCESSING  PARAMETERS  TO  DEFAULT  ', 

*  'VALUES',/, 

*2X,'SP  -  SET/LIST  PROCESSING  PARAMETERS',/, 

*2X,'FRNT  -  GENERATE  FRONT  CURVE  (FRONT)',/, 

•2X,'LIST  -  LIST  X,Y  COORDINATES  OF  FRONT  CURVE',/, 

*2X,'HELM  -  APPLY  HELMHOLTZ  EQUATION  SOLVER  (MASK,HELM)' ,/, 
*2X,'RES  -  RESUME  HELMHOLTZ  EQUATION  SOLVER  (HELM)',/, 
*2X,'TS  -  GENERATE  TEMPERATURE,  SALINITY,  DENSITY  AND  ', 

*  'FREQUENCY  PROFILES  (TS)',/, 

*2X,'LP  -  LIST  TEMPERATURE,  SALNITY,  DENSITY  AND  FREQUENCY 

*  'PROFILES',/, 

•2X,'SIG  -  GENERATE  SIGMA  FIELD  <NUVD,NUINT)',/, 

*2X,'SV  -  GENERATE  SOUND  VELOCITY,  BLENDED  TEMPERATURE  OR  ' 

*  'BLENDED  SALINITY',/, 

*2X,'  OUTPUT  (BLENDTS)',/, 

•2X,'ENO  -  END  THE  PROGRAM') 

GO  TO  100 
C 

C  SF  -  SET  UP  EXTERNAL  FILES  TO  PROCESS 
C 

300  CALL  SETFS(IRD,IUR,NWFN,JBUF,IH,FA,IA,IST) 

IFdST  .EQ.  -1)  GO  TO  9000 
URITE(LUCF,REC-2)  ( JBUFd ), I>1 ,NUPRCF) 

GO  TO  100 
C 

C  IN  •  INITIALIZE  PARAMETERS 
C 

400  CALL  INPAR(MXFCPS,IBUF) 

URITE(LUCF.REC-I)  (IBUFd ), I>1,NWPRCF) 

GO  TO  100 
C 

C  SP  •  SET  PARAMETERS 
C 

500  CALL  SETPARdRO,IWR,MXFCPS,IBUF,IH,FA,IA,IST) 

IFdST  .EQ.  -1)  GO  TO  9000 
URITE(LUCF,REC<>1)  (IBUFd ),  1=1  ,NUPRCF) 

GO  TO  100 
C 

C  FRNT  •  GENERATE  FRONT  CURVE 
C 

600  NPTS>IBUF(11) 

LM>IBUF(12) 

RLP<XBUF(13) 

ITER>IBUF(U) 

0LM«LM*2.>1. 

C 

C  OBTAIN  CURRENT  TIME  IN  SECONDS  AS  INITIAL  SEED  TO  CALL 
C  RANDOM  NUMBER  GENERATOR 

C 

CALL  DATIMEdH,FA,ISEC) 

IF(MGOdSEC,2)  .EQ.  0)  ISEC«ISEC«1 
ISEC=99997 
C 

C  CREATE  UAVE  NUMBER  (AK),  AMPLITUDE  (A),  PHASE  (PHI) 

C 

DO  602  1=0,100 

AK(I)=.25*(,5*I)**2*1.*.3*((RAN(ISEC))-.5) 

A(I)»1./(1.*AK(I)«*RLP) 

PH I (I )>2 . *3 . 141 59»RAN( I SEC ) 

602  CONTINUE 
C 

C  CREATE  INITIAL  CURVE  VALUES,  RESULT  IS  A  STRAIGHT  LINE 
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c 

0=NPTS 

010=0/10. 

00  604  1=1,NPTS 
0=1 

X<I)=0/010 

T(1)=X(1) 

Y( I )=( .5+1 .5*T( I )/10. )»A{0)*SIN(AK(0)*T( I )+PHI(0)> 

604  CONTINUE 

C 

C 

00  690  X=1,1TER 
WRITE! IWR, 610)  K 

610  F0RMAT(2X,' ITERATION  =  >,14) 

C 

C  FIRST  PASS  THROUGH  FULL  ARRAY  GENERATION 
C 

YY»A<K)*SIH(AIC(K)*T(  1  )+PHI  (K)  ) 

X0=X(3)*X(1) 

Y0=Y(3)-Y(1) 

Z»SORT(XO*XO+YO*YO) 

X1(1)=X(1)-Y0*YY/Z 
Y1(1)=Y(1)+X0*YY/Z 
00  616  I=2.HPTS 

YY=<  .5+1 .5*<T<  I  )/T<NPTS)))*A<IC)*SIN<AK(K)*T{I  )+PHI  (K)) 
C 

C  LEAST  SQUARES  FIT  OVER  +/-  LN  REPLACES  NEEO  FOR  OERIVATIVES 
C 

IF<I  .LT.  NPTS)  THEN 
C 

C  NEAR  BOUNOARIES  CHECK 
C 

IF(I  .LT.  11  .OR.  I  .GT.  <NPTS-11))  THEN 
X0»X<I+1)-X(I-1) 

Y0=Y<I+1)-Y(I-1) 

ELSE 

X0=0. 

Y0«0. 

00  614  J«1,10 
0-J 

X0=X0+0*(X<I+J)*X<I-J)) 

Y0=Y0+0*<Y(I+J)-Y<I-J)) 

614  CONTINUE 

ENOIF 
ENOIF 
C 

C  CREATE  ALONGSTREAM  VALUE  FROM  X,Y  OELTAS 
C 

2»SQRT<XD»X0+Y0*Y0) 

X1(I)«X(I)-V0*YY/Z 
Y1<I)»Y(I)+X0*YT/Z 
616  CONTINUE 

C 

C  ONCE  ROUGH  CURVE  IS  CREATED.  GO  BACK  WITH  A  SMOOTHING  FUNCTION 
C 

00  618  l«0,LN 
X1<-I)=X1(1) 

Y1(-I)«Y1(1) 

X1(NPTS+I)-X1(NPTS) 

Y1(NPT8+I)«Y1<NPTS) 

618  CONTINUE 

C 

C  GET  FILTERED  X.Y  VALUES  IN  "CENTER"  OF  FILTER  WIDTH 
C 

DO  630  1=1, NPTS 
X(I)=0. 

Y(I)»0. 

DO  620  J«-LM,LM 
X(I)»X(I)+X1<I+J) 
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V(I)»Y(I)*Y1(HJ> 

620  CONTINUE 

X( I )>X( I )/DLN 
Y(I)=Y(I)/0LN 
630  CONTINUE 
690  CONTINUE 

IBUF(20)3NPTS 

IF(IBUF(3)  .LE.  0>  IBUF(3)=1BUF(2)»1 
IREC>IBUF(3}-1 
DO  694  I>1,MXFCPS,NUPRCF/2 
J*I+NWPRCF/2-1 
IREC^IREC^I 

WRITE(LUCF.REC=IREC)  (X(K),Y(K),K=I.J) 

694  CONTINUE 

IBUF(2)>IREC 

URITE(LUCF.REC«1)  (IBUF( I ). I>1 .NWPRCF) 

GO  TO  100 
C 

C  LIST  -  LIST  X.Y  OF  FRONT  CURVE 
C 

700  IBP>IA(1)  . 

IEP-IA(2) 

C 

C  CHECK  NUMBER  OF  POINTS  OF  THE  FRONT  CURVE  STORED 
C 

IREC*IBUF(3)-1 

NPTS>IBUF<20) 

IFTNPTS  .LE.  0)  THEN 
URITE(IUR.710) 

710  FORMAT (2X, ‘FRONT  CURVE  HAS  NOT  BEEN  GENERATED  YET‘) 

GO  TO  100 
ENOIF 
C 
C 

URITEdUR  712}  NPTS 

712  FORMAT (2x1 ‘TOTAL  NUMBER  OF  FRONT  CURVE  POINTS:  ‘.I4> 

IFdBP  .Ed.  0)  THEN 
URITEdUR, 714) 

714  F0RMAT(2X, ‘ENTER  BEGINNING  AND  ENDING  POINTS  TO  LIST‘) 
CALL  RUIdRO,IUR.IH,FA.IA,NVS) 

ENOIF 

IBP>MAX0dA(1},1) 

IEP>MIN0dA(2).NPTS) 
lEP-MAXOdBP,  lEP) 

URITEdUR, 716) 

716  FORMAT(2X,‘POINT‘,11X,‘X‘,11X,‘Y‘) 

DO  730  I-1,IEP,NUPRCF/2 
J»I*NUPHCF/2-1 
IREC«IREC+1 

REAO(LUCF,REC>IREC)  (X(K),Y(K),K«I , J) 

DO  720  K«I,J 

IF(K.GE.IBP  .AND.  K.LE.IEP)  THEN 
URlTEdUR,718)  K,X(K),Y(K) 

718  F0RMAT(2X,IS,2X,F10.5,2X,F10.S) 

ENOIF 

720  CONTINUE 
730  CONTINUE 
GO  TO  100 
C 

C  HELM  •  APPLY  HELMHOLTZ  EQUATION  SOLVER 
C 

800  IREC*IBUF(3)-1 
NPTS-IBUF(20) 

IF(HPTS  .LE.  0)  TI«N 
URITEdUR,  710) 

GO  TO  100 
ENOIF 
C 
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C  CHECK  IF  HMF  FILE  IS  SET 
C 

IF(JBUF(21>  .EQ.  BLANKS)  THEN 
URITE{IWR,802)  FILTYP(2) 

802  FORHAT(2X,A4,'  FILE  NAME  HAS  NOT  BEEN  DEFINED',/, 

*  2X,'USE  DIRECTIVE  SF  TO  SET  THE  FILE  NAME') 
GO  TO  100 

ELSE 

URITE(HMFN,30)  ( JBUF( I ), 1=21 ,20>NUFN) 

CALL  CKFILE(IWR,2,HMFN,2,LUS,LUSO,FILTVP,MXROWS,1ST) 
IFdST  .EQ.  -1)  GO  TO  100 
END  IF 
C 

C  READ  FRONT  CURVE  IN 
C 

812  DO  816  I>1,NPTS,NUPRCF/2 
J*I+NUPRCF/2-1 
IREC=IREC'»1 

REAO(LUCF,REC=IREC)  (X<K),Y(K),K=I,J) 

816  CONTINUE 
C 

C  FIND  MIN  AND  MAX  X  VALUES  BETWEEN  POINTS  51  AND  NPTS-50 
C 

XMIN-X(51) 

XMAX«XHIN 

DO  818  I'>S2,NPTS-S0 

IF(X(I)  .LT.  XHIN)  THEN 
XMIN=X(I) 

ELSE 

IF(X(I)  .GT.  XMAX)  XMAX=X(I) 

END  IF 
818  CONTINUE 
C 

C  RESCALE  X,Y  TO  FIT  IN  MASK  BUFFER 
C 

0=MXC0LS 

SCALE=D/(XMAX-XMIN) 

MPTS'-O 
IX(MPTS)*0 
IY(MPTS)=MXROWS/2 
DO  820  I=51,NPTS-SO 

IXX*(X<I)-XMIN)*SCALE+.5 

IYY»Y<I)»SCALE+.5 

IYY»IYY+IY(0) 

IF((IXX.NE.IX(HPTS)  .OR.  lYY.NE.IY(NPTS))  .AND. 

*  IXX.GE.1)  THEN 
MPTS=MPTS*1 
IX(MPTS)=IXX 
IY<MPTS)«IYY 

IF(IX(MPTS)  .GE.  MXCOIS)  GO  TO  822 
ENDIF 
820  CONTINUE 
C 

C  INITIALIZE  MASK  BUFFER 
C 

822  WRITE(IWR,82A) 

824  F0RNAT(2X, 'GENERATING  0  MASK') 

DO  830  I>1,MXROWS 
DO  828  J>1,MXCOLS 
MASK(J,t)>1 
828  CONTINUE 
830  CONTINUE 
C 

C  SET  LOCATIONS  OF  FRONT  CURVE  TO  O'S 
C 

DO  832  I«1,MPTS 

NASX(IX(I),IY(I))>0 
832  CONTINUE 
C 
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C  SET  PIXELS  BELOW  THE  FRONT  CURVE  TO  -1'S 
C 

DO  840  I=1,MPTS 
IDIR^O 

JDIR=IY(I)-IY(I-1) 

IF(I  .LT.  HPTS)  THEM 
IF(JOIR  .GE.  0)  THEN 
I0IR=IX(I)-IX(I-1) 

ELSE 

IDIR=IX<I+1)-IX(I) 

END  IF 
ELSE 

IDIR=1 
END  IF 

IFdDIR  .GT.  0)  THEN 
DO  836  J=1,IY<I)-1 
K*IY(I)-J 

IF(NASK(IX(I),K)  .EO.  0)  GO  TO  840 
MASK(IX(I),K)=-1 
836  CONTINUE 

END  IF 
840  CONTINUE 
C 

C  PERFORM  FIRST  ORDER  CHECK  ON  Q  BUFFER 
C 

NOK=0 

uO  860  I=1,MXCOLS 
IMINUSsO 
IPLUS>0 

DO  850  J=1,MXROUS 

IF(MASK<I,J)  .LT.  0)  THEN 
ININUS»ININUS+1 
ELSE 

IF(MASK(I,J)  .GT.  0)  IPLUS^IPLUS^I 
END  IF 

850  CONTINUE 

NTOTAL-IMINUS^IPLUS 

IF(NTOTAL.LE.(NXROWS-1}  .AND.  IMINUS.GT.20  .AND. 

*  IPLUS.GT.20)  NOK=NOK>1 
860  CONTINUE 

1F(N0K  .LT.  MXCOLS)  THEN 
I^MXCOLS-NOK 
WRITE! lUR, 862)  I 

862  FORMAT (2X, 'WARNING  -  '.K.'  COLUMNS  IN  Q  MASK  FAILED 

•  'TO  PASS  FIRST  ORDER  CHECK') 

WRITE! IWR, 864) 

864  FORMAT !2X, 'CONTINUE,  Y/N?') 

CALL  RUI!IRD,IWR,IH.FA,IA,NVS) 

IF!IH!1).NE.YES!1)  .AND.  IH!l).NE.YES!2))  THEN 
CALL  CLSFIL!LUSO,MXFS) 

GO  TO  100 
END  IF 
ELSE 

WRITE! IWR, 866) 

866  FORMAT!2X,'Q  MASK  PASSED  FIRST  ORDER  CHECK') 

ENDIF 

C 

C  SAVE  Q  MASK  TO  CONTROL  FILE 
C 

IF!I8UF!5)  .LE.  0)  IBUF!5)>IBUF!2)-»1 

IREC>>IBUF!5)-1 

DO  880  I>1,MXROWS 

DO  870  J>1, MXCOLS, NWPRCF*2 
K»J+MWPRCF*2-1 
K>MIN0!K, MXCOLS) 

IREC>IREC«1 

WRITE  .UCF,REC>IREC)  !MASK!L, I ),L>J,K) 

870  CONTINUL 
880  CONTINUE 
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lBUF(2)sIREC 

C 

C  FIND  WHERE  FRONT  CROSSES  LEFT  AND  RIGHT  BOUNDARIES 
C 

DO  882  I=1,HXROUS 

IF(NASK(1,I)  .EQ.  0)  IMINUS=I 
IF(MASK(HXCOLS.I)  .EQ.  0)  IPLUSsI 
882  CONTINUE 
C 

C  SAVE  HELM  PROCESSING  PARAMETERS 
C 

IBUF(28)=1 

IBUF(29)=IMINUS 

IBUF(30)>IPLUS 

C 

C  INITIALIZE  Q  MATRIX  BUFFER 
C 

DO  892  I>1,MXROUS 
DO  890  J>1,MXCOLS 
Q{J,I)=0. 

890  CONTINUE 
892  CONTINUE 
GO  TO  930 
C 

C  RES  -  RESUME  HELM  PROCESS 
C 

900  IF(IBUF(5)  .LE.  0)  THEN 
URITE(IUR.902) 

902  FORMAT<2X,<Q  MASK  HAS  NOT  BEEN  GENERATED  YET  -  EXECUTE  *, 
•  'DIRECTIVE  HELM  FIRST') 

END  IF 
C 

C  CHECK  EXISTENCE  OF  HMF  FILE 
C 

IF(JBUF(21)  .EQ.  BLANKS)  THEN 
WRITE(IWR,802)  FILTyP(2) 

GO  TO  100 
ELSE 

HRITE(HMFN,30)  ( JBUFC I ), 1321 ,20+NWFN) 

CALL  CKF I LE< I WR , 1 , HMFN, 2, LUS, LUSO, F I LTYP.MXROWS,  I ST ) 
IFdST  .NE.  O)  GO  TO  100 
END  IF 
C 

C  READ  IN  Q  MATRIX 
C 

URITE(IWR,910)  FILTYP(2) 

910  FORMAT (2X, 'READING  ',A4,'  FILE') 

DO  912  I-1,MXCOLS 

REAO(LUNMF,REC3l)  (Q(I, J),J3l,MXROWS) 

912  CONTINUE 
C 

C  READ  IN  Q  MASK  FROM  CONTROL  FILE 
C 

IREC3lBUF(5)-1 
DO  920  I>1,NXROWS 

DO  9U  J>1,MXCOLS,NWPRCF*2 
K»J^NWPRCF*2-1 
K«MINO(K,MXCOLS) 

IREC«IREC«^1 

REAO(LUCF,REC>IREC)  (MASK(L, I I.L-J.K) 

914  CONTINUE 
920  CONTINUE 
C 
C 

930  ALFA>XBUF(21) 

BETA>XBUF(22) 

H«XBUF(23) 

MAXH-I8UF(24) 

NINH>IBUF(2S) 


24 


JTER>IBUF(26) 

1START-IBUF(28) 

IMINUS*IBUF(29) 

IPLUSsIBUF(30) 

WRITE(IUR,932>  ISTART.JTER 
932  FORMAT ( 

*2X, 'EXECUTING  HELMHOLTZ  EQUATION  SOLVER',/, 

*2X, 'STARTING  ITERATION  NUMBER:  ',14,',  LAST  ITERATION  ', 

*  'NUMBER:  ',14) 

I F( I  START  .GT.  JTER)  THEN 
URITE(IUR,934) 

934  FORMAT(2X,'HELM  PROCESS  WAS  COMPLETED') 

CALL  CLSFIL(LUSO,MXFS) 

GO  TO  100 
END  IF 

B2>1 ./(BETA*BETA) 

H2=H*H 

SLAM2=B2*N2 

SLAM>SQRT(SLAM2) 

ETA(-1)^INH 

ETA(0)>0. 

ETA(1)3MAXH 

C 

C  CHECK  IF  BOUNDARIES  SHOULD  BE  INITIALIZED 
C 

IFdSTART  .EQ.  1)  THEN 
DO  936  I-1,NXCOLS 
Q(I,1)-MINH 
0(I,MXR0WS)>MAXH 
936  CONTINUE 

DO  938  I-1,MXROUS 
J>MASK(1,I) 

O-IABS(I-IMINUS) 

Q(1, I )=ETA<J)*<1.-EXP< -BLAM'D)) 

J>MASK(MXROUS, I ) 

D*IABS(I-IPLUS) 

Q<MXCOLS, I)«ETA< J)*(1 .•EXP(-SLAM'D)) 

938  CONTINUE 

END  IF 
C 

C  HELM  SOLVER 
C 

DO  970  I>ISTART,JTER 
RMAX«0. 

DO  960  J>2,MXCOLS-1 
DO  950  K«2,MXROWS-1 
L>MASK(J,K) 

IF(L  .NE.  0)  THEN 

R«ALFA*(.25*<0(J-1,K)+Q<J*1,K)+0<J,K*1)* 

*  Q<J,K-1)-4.*0(J,K))-SLAM2*<0(J,K)-ETA<L))) 
ELSE 

R>0. 

ENOIF 

a(J,K)«Q(J,K)^R 

R-ABS(R) 

IF(RMAX  .LT.  R)  RMAX-R 
950  CONTINUE 

960  CONTINUE 

URITEClUR  962)  I  RMAX 

962  FORMAT(2x|' ITERATION:  ',14,',  MAXIMUM  ERROR:  ',620.8) 

IF(MOO(I,50)  .EQ.  1)  THEN 
DO  964  K>1 ,MXCOLS 

URITE(LUHMF,REC«K)  (Q(K, J),J«1,MXROUS) 

964  CONTINUE 

IBUF(28)>I>1 

URITE(LUCF,REC-1)  (IBUF(K),K«1,NWPRCF) 

CALL  OATIME(IH,IA,ISEC) 

JBUF(NUFN«21)«IH(1) 

JBUF(NWFN-»22)>IH(2) 
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JBUF(NUFN-»23)sIA(1) 

JBUF<NWFN«24)>IA(2) 

URITE(LUCF.REC>:2)  ( JBUF(K},K3l .NWPRCF) 

END  IF 
970  CONTINUE 

IF(MOO(JTER,SO)  .NE.  1)  THEN 
DO  974  K>1,MXCOLS 

WRITE(LUHNF,REC-K}  (Q(K, J), J=1,MXROWS) 

974  CONTimJE 

IBUF(28}>JTER'^1 

URITE<LUCF.RECs1)  (IBUF(K>.K=1,NWPRCF} 

CALL  DATINE(IH,IA,ISEC) 

JBUF(NUFN4'21)>IH(1) 

JBUF(NWFN-»22)sIH(2) 

JBUF(NUFN-»23)>IA(1) 

JBUF(NUFN'»24}aIA(2> 

URITE(LUCF,RECx2)  (JBUFdO.K^l.NWPRCF) 

ENDIF 

CALL  CLSFIL(LUSO.NXFS) 

GO  TO  100 
C 

C  TS  -  CREATE  TENPERATURE  AND  SALINITY  PROFILES 
C 

1000  NAXHaIBUF(24) 

NINH>IBUF(25) 

LAT>I8UF(31) 

LONG«IBUF(32) 

IZ>IBUF(33> 

I-ZLEV(NXZS) 

NZSaI/IZ'^1 

IF(NOO(I,IZ)  .NE.  0)  THEN 
URITE(IUR,1002)  I.IZ 

1002  FORMAT (2X, 'MAXIMUM  DEPTH  ',14,'  IS  NOT  EVENLY  DIVISIBLE 

•  'BY  PARAMETER  IZ:  ',14) 

GO  TO  100 
ENDIF 

I>1ABS(MAXH)/IZ«1 
J>IABS(MINH)/IZ«1 
MZS*NZS*UJ>1 
IF(MZS  .GT.  MXVS)  THEN 
URITEdUR  10041 

1004  FORMAT (2X I 'PARAMETER  IZ  IS  TOO  SMALL') 

GO  TO  100 
ENDIF 
C 

C  CHECK  EXISTENCE  OF  LEVITUS  DATABASE  FILE 
C 

IF(JBUF(1)  .EO.  BLANKS)  THEN 
URITE(IWR,802)  FILTYP(3) 

ELSE 

NRITE(0FN.80)  (J8UF(I),I«1,12) 

CALL  CKFILE(IUR,1,DFN,3,LUS,LUSO,FILTYP,180,IST) 

IFdST  .NE.  0)  GO  TO  100 
ENDIF 
C 

C  READ  TEMPERATURE  AND  SALINITY  PROFILES  IN  FROM  LEVITUS  DATABASE 
C 

CALL  R0TS(LUDBF,L0NG,LAT,TEMP,SAL,180,XDBF} 

CALL  CLSFIL(LUSO,MXFS) 

C 

C  SET  UP  DEPTH  INDEX  TABLE 
C 

DO  1024  I«1,NZS 
DEPO(I)«(I-1)*IZ 
1024  CONTINUE 
C 

C  INTERPOLATE  TEMPERATURE  AND  SALINITY  PROFILES 
C 

CALL  INTRPL(IUR,MXZS,ZLEV,TEMP,NZS,OEPO,TEMPO) 
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CALL  INTRPL( lUR ,NXZS, ZLEV, SAL , NZS.DEPO, SALO) 

C 

C 

PR*0. 

DO  1030  I>1,NZS-1 
C 

C  COMPUTE  BRUNT-VAISALA  FREQUENCIES 
C 

BVFO( I ) sBVFRQC SALO(  I ) , TEMPO( I ) , OEPO( I ) , 2, PAV, E ) 

C 

C  USE  SIMPLE  TEMPERATURE  INSTEAD  OF  POTENTIAL  TEMPERATURE  (THETA) 

C 

DUM«SVAN( SALO( I ) , TEMPO( I ) , PR , S I  GO( I ) ) 

1030  CONTINUE 

BVFO(NZS}=BVFO(NZS-1}'^(BVFC(NZS-1)-BVFO(NZS-2)) 

DUM=SVAN (SALO( NZS > , TEMPO( NZS ) , PR , S I GO( NZS ) ) 

C 

C  FIND  SIGMA  VALUE  BASED  UPON  MAXIMUM  BVF  VALUE 
C 

I0XMAX>1 

BVFMAX>BVFO(IOXMAX) 

DO  1040  I>2,NZS 

IF(BVFO(i)  .GT.  BVFMAX)  THEN 
IDXMAX*! 

BVFMAX-BVFOd) 

ENOIF 
1040  CONTINUE 

S>StGO(IOXMAX) 

URITETIUR  1042)  S  BVFMAX 

1042  FORMAT(2x! 'SIGMA  VALUE:  ',F10.5,'  FOUND  AT  BVF  VALUE:  ‘.FIO.S) 
C 

C  SAVE  MAXIMUM  SIGMA  VALUE  TO  CONTROL  FILE 
C 

IBUF(35)>MAXH 

IBUF(36)aMINH 

IBUF(37)>IZ 

IBUF(38)«N2S 

IBUF(39)«!lDXMAX 

XBUF(40)>S 

C 

C  STORE  DEPTH,  TEMPERATURE,  SALINITY,  SIGMA,  BVF  PROFILES  TO 
C  CONTROL  FILE 

C 

IF(IBUF(7)  .LE.  0)  IBUF(7)*IBUF<2)+1 
IREC-IBUF(7)-1 
DO  1050  I-1,NXVS,NUPRCF/S 
J-I+NNPRCF/5-1 
IREC>IREC«1 

URITE(LUCF,REC«IREC)  (DEPO(K),TENPO(K),SALO(K),SiGO(K>, 

*  BVFO(K),K>I,J} 

1050  CONTINUE 

IBUF(2)«IREC 

URITE(LUCF,REC>1)  (IBUF(n,I>1,NUPRCF) 

GO  TO  100 
C 

C  LP  -  LIST  DENSITY  AND  FREQUENCY  PROFILES 
C 

1100  IBP>IA(1) 

IEP«IA(2) 

IF(IBUF(7)  .LE.  0)  THEN 
URITE(INR,1102) 

1102  FORMAT(2x|'NO  DENSITY  AND  BVF  DATA  STORED  IN  THE  CONTROL  ', 

•  'FILE  -  EXECUTE  DIRECTIVE  TS  FIRST') 

GO  TO  100 

ENOIF 

C 

C 

IREC>>IBUF(7)-1 

NZS>IBUF(38) 
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WRITE(IUR,1104)  NZS 

1104  FORMAT (2X, 'TOTAL  NUMBER  OF  DENSITY  AND  FREQUENCY  VALUES 

*  ‘STORED:  ',14) 

IF(IBP  .EQ.  0)  THEN 

URITE(IWR.1106) 

1106  FORMAT (2X, 'ENTER  BEGINNING  AND  ENDING  VALUES  TO  LIST') 
CALL  RUI(IRO,IUR,IH,FA.IA.NVS) 

ENDIF 

IBP»MAX0(IA(1),1) 

IEP>MIN0(IA(2),NZS) 

IEP>MAXO(IBP,IEP) 

URITEdUR.mO) 

1110  F0RMAT<2X. 'VALUE', 8X, 'DEPTH', 2X, 'TEMPERATURE', 5X, 'SALINITY'. 

*  6X,'0ENSITY',4X,' FREQUENCY') 

DO  1130  I>1,IEP.NUPRCF/S 

Jxl+NUPRCF/S-I 

IREC>IREC'»1 

REAO(LUCF,REC>IREC)  (DEP(K),TEMP(K),SAL(X),SIG(K). 

*  BVF<K),K=I,J) 

DO  1128  K>=I,J 

IF(K.GE.IBP  .AND.  K.LE.IEP)  THEN 

URITE(IUR,1126)  K,DEP(K),TEMP(K),SAL(K),SIG(K), 

*  BVF(K) 

1126  FORNAT(2X,I5,S(3X,F10.S)) 

ENDIF 

1128  CONTINUE 
1130  CONTINUE 
GO  TO  100 
C 

C  SIG  •  GENERATE  SIGMA  FIELD 
C 

1200  IF(IBUF(7)  .LE.  0)  THEN 
WRITE(IUR,1102) 

GO  TO  100 
ENDIF 

MAXN«IBUF(35) 

MINH«I8UF<36) 

IZ>IBUF(37) 

NZS>IBUF<38) 

C 

C  CHECK  EXISTENCE  OF  Q  MATRIX  FILE 
C 

IF(JBUF(21)  .EQ.  BLNAKS)  THEN 
URITE(IUR,802)  FILTYP(2) 

GO  TO  100 
ELSE 

WRITE<HMFN,30)  < JBUFd  ),  I«21  .EO^’NWFN) 

CALL  CKFILEdUR,1,HMFN,2,LUS,LUS0.FILTYP,MXR0US,IST) 
IFdST  .NE.  0)  GO  TO  100 
ENDIF 
C 

C  CHECK  SFF  FILE  NAME 
C 

IF(JBUF(31)  .EO.  BLANKS)  THEN 
WRITEdUR,802)  FILTYP<4) 

CALL  CLSFIL(LUSO,MXFS) 

GO  TO  too 
ELSE 

URITE(SFFN,30)  (JBUFd),I>31,30HMFN) 

CALL  CKFILEdUR,2,SFFN,4,LUS,LUSO,FILTYP,NZS,IST) 

IFdST  .EO.  -1)  THEN 
CALL  CLSFIL(LUSO.NXFS) 

GO  TO  100 
ENDIF 
ENDIF 
C 

C  GET  FIRST  END  POINT 
C 

URITEdUR,1220) 
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1220  F0IWAT(2X, 'ENTER  X,Y  OF  FIRST  EM)  F>01NT') 

CALL  RUI(IR0,IUR,1H.FA,IA,NVS> 

IF(IA(1).LT.1  .OR.  lA(l).GT.NXCOLS)  THEN 
URITE(IWR,1222)  NXCOLS 

1222  FORNAT(2X,'X  COORDINATE  CANNOT  BE  <  1  OR  >  ',14) 

CALL  CLSFIL(LUSO,MXFS) 

GO  TO  100 
ELSE 

IF(IA(2).LT.1  .OR.  IA(2).GT.MXROUS)  THEN 
URITE(IUR,1224)  MXROWS 

1224  FORMAT(2X,'Y  COORDINATE  CANNOT  BE  <  1  OR  >  *,14) 

CALL  CLSFIL(LUSO.MXFS) 

GO  TO  100 
END  IF 
END  IF 
IXIsIA(l) 

IY1«IA(2) 

C 

C  GET  SECOND  END  POINT 
C 

URITE(IWR,1226) 

1226  FORMAT (2X, 'ENTER  X,Y  OF  SECOND  END  POINT') 

CALL  RUI(IRD,IWR,IH,FA,IA,NVS) 

IF(IA(1).LT.1  .OR.  lA(l).GT.NXCOLS)  THEN 
URITE(IUR,1222)  NXCOLS 
CALL  CLSFIL(LUSO,MXFS) 

GO  TO  100 
ELSE 

IF(IA(2).LT.1  .OR.  IA(2).GT.NXROWS)  THEN 
URITE(IWR,1224)  MXROWS 
CALL  CLSFIL(LUSO.NXFS) 

GO  TO  100 
ENOIF 
ENOIF 
IX2«IA(1) 

IY2«IA(2) 

C 

C  INTERPOLATE  THE  POINTS  BETWEEN  TWO  END  POINTS 
C 

CALL  DLXY< 1X1 , IY1 , 1X2, 1 Y2,MPTS,NXVS, IXS, lYS) 

IF(NPTS  .GT.  NXVS)  THEN 
WRITE(INR,1228)  MXVS 

1228  FORMAT (2X, 'MORE  THAN  ',14,'  POINTS  ARE  FOUND  BETWEEN  ', 

*  'THE  TWO  ENO  POINTS') 

GO  TO  100 

ENOIF 

C 

C  READ  IN  TEMPERATURE,  SALINITY,  SIGMA  AND  BVF  PROFILES  FROM  THE  CONTROL  FILE 
C 

IREC«IBUF(7)-1 
DO  1230  Ia1,NZS,NWPRCF/5 
J«I4NWPRCF/5-1 
IREC-IRE01 

REAO(LUCF,REC>IREC)  (OEP(K),TENP(K),SAL(K),SIG(K), 

*  BVF(K),K«I,J) 

1230  CONTINUE 

C 

C  SET  UP  DEPTH  RANGE  INCLUDING  MINN  AND  MAXH  AM)  SHIFT  SIGMA  AND  BVF 
C  DATA  ACCORDINGLY 
C 

MZS-IABS(NINH/IZ)«1 
DO  1232  I*NZS,1,-1 
0EP(N2S«I)«(I-1)*IZ 
BVF(MZS«I)>BVF(I) 

SIG(MZS«I)>SIG(I) 

1232  CONTINUE 

DO  1234  I>MZS,1,-1 
0EP(I)*0EP(I>1)-IZ 
BVF(I)>fVF(I«1) 
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SIG(I)>SIG(1>1) 

123A  CONTINUE 
J=MZS«NZS 

NZS3lABS(MAXH)/IZ-»1 
DO  1236  I>1,NZS 

OEP<J*I)«OEP(J>I-1)*IZ 

BVF(J+I)*BVF(J*I-1) 

SIG(J-»I)*SIG(J+I-1) 

1236  CONTINUE 
MZSsJ-^ZS 
C 

C  FIND  DEPTH  FOR  THE  MAXIMUM  BVF  VALUE 
C 

BVFMAX>BVF<1) 

DEPTH>OEP(1) 

DO  1238  I*2,MZS 

IF(BVF(I)  .GT.  BVFMAX)  THEN 
BVFMAX>BVF(I) 

DEPTH^OEPd) 

END  IF 
1238  CONTINUE 
C 
C 

IREC>0 

DO  1260  I>1,MPTS 

IFdREC  .NE.  IXSd))  THEN 
IREC«IXSd) 

READ(LUHMF,REC*IREC)  (QdREC.J), J>1,MXR0US) 
ENOIF 

QV-0dREC,irS<I)) 

IF(QV  .LE.  DEPTH)  THEN 
LZS>0 
ELSE 

D»QV-DEPTH 

LZS«0/IZ 

D1aL2S*IZ 

IF(D1  .LT.  D)  LZSaLZS^I 
ENOIF 
KaO 

DO  1242  J»L2S,1,-1 
KaK+1 

DEP0<J)*0V-<IC*I2) 

1242  CONTINUE 

DO  1244  Jal.NZS 

OEPO<  LZS't' J  )»0V*<  J  •  1  )*  I Z 
1244  CONTINUE 

KZSaNZS^LZS 

IDXaLZS-d 

CALL  INTRPLdW.NZS.OEP.BVF.KZS.DEPO.BVFO) 

CALL  INTRPLdUR,MZS,DEP,SIG,KZS.DEPO.SIGO) 

CALL  SIGINTdZ,KZS,BVFO,SIGO) 
URITE(LUSFF,RECaI)  (SIGO(J),J«IOX,KZS) 

IFd  .EO.  1)  THEN 
SIGNIN-SIGOdOX) 

IA(1)al 

IA(2)a1 

SlGNAXaSlGMlH 

IA(3)a|A(1) 

IA(4)a|A(2) 

ENOIF 

DO  12S0  JalDX.KZS 

IF(SIGO(J)  .LT.  SIGMIN)  THEN 
SIGMINaSIGO<J) 

IA<1)aI 

IA(2)aJ-IDX'»1 

ELSE 

IF(SIGO(J)  .GT.  SIGMAX)  THEN 
SIGMAXaSlGO(J) 

IA(3)aI 
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IA(4)-J-IDX>1 

ENOIF 

ENDIF 

1250  CONTINUE 

IF(MOO(I,SO)  .EQ.  0)  THEN 
URITE(IUR,1252)  I.MPTS 

1252  FORMAT (2X, 'COMPLETED  POINT  NUMBER:  ',14.',  TOTAL  NUMBER 

*  'OF  POINTS  TO  PROCESS:  ',14) 

ENOIF 

1260  CONTINUE 

IF(MOO(HPTS,50)  .NE.  0}  URITE(IUR,1252)  MPTS.HPTS 
CALL  CLSFIL(LUSO,HXFS) 

IBUF(41)-IX1 

IBUF<42)»IY1 

IBUF(43)>IX2 

IBUF(44)>IY2 

XBUF(45)>SIGMIN 

XBUF(46)>SIGMAX 

IBUF(47)«NINH 

IBUF(4B)>MAXH 

IBUF(49)>IZ 

IBUF(50)>NZS 

WRITE! IWR, 1262)  SIGMIN,IA(1),IA(2) 

1262  FORMAT(2X, 'MINIMUM  SIGMA  VALUE:  ',F10.5.'  FOUND  AT  X.Y  ', 

*  'LOCATION:  ',14, ',',14) 

WRITE! IWR, 1264)  SIGMAX, IA!3), IA!4) 

1264  FORMAT !2X, 'MAXIMUM  SIGMA  VALUE:  ',F10.5,'  FOUND  AT  X,Y  ', 

*  'LOCATION:  ',14, ',',14) 

URITE!LUCF,REC«1)  !IBUF!I),I*1,NWPRCF) 

CALL  0ATIME!IH,IA,ISEC) 

JBUF!3UNWFN)>IH!1) 

JBUF!32>NUFN)>IH!2) 

JBUF!33''-NWFN)>IA!1) 

JBUF!344-NWFN)«IA!2) 

WRITE!LUCF,REC>2)  !JBUF!I),I31,NWPRCF) 

GO  TO  100 
C 

C  SV  •  GENERATE  SOUND  VELOCITY,  TEMPERATURE  OR  SALINITY  OUTPUT 
C 

1300  IF!JBUF!1)  .EQ.  BLANKS)  THEN 
WRITE! IWR, 802)  FILTYP!3) 

ELSE 

WRITE!0FN,80)  !JBUF!I),I>1,12) 

CALL  CKFILE!IWR,1,DFN,3,LUS,LUSO,FILTYP,180,IST) 

IF!IST  .NE.  0)  GO  TO  100 
ENOIF 
C 

C  CHECK  EXISTENCE  OF  HMF  FILE 
C 

IF!JBUF!21)  .EQ.  BLANKS)  THEN 
WRITE! IWR, 802)  FILTYP!2) 

CALL  CLSFIL!LUSO,MXFS) 

GO  TO  100 
ELSE 

WRITE!HMFN,30)  !JBUF!I),I-21,20»NUFN) 

CALL  CXF I LE! IWR , 1 , HMFN ,2, LUS, LUSO, F ILTYP.MXROWS, I ST) 

IF!IST  .HE.  0)  THEN 

CALL  CLSFIL!LUSO,MXFS) 

GO  TO  100 
ENOIF 
ENOIF 


IX1«IBUF!41) 

IY1-IBUF!42) 

IX2«IBUF!43) 

IT2>IBUF!44) 

SIGNIN-X8UF!45) 

SIGMAX«XBUF!46) 
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NINHs{BUF(47) 

NAXH«IBUF(48) 

IZ>IBUF(49) 

NZS«IBUF(50} 

E>XBUF(51) 

1RCF>IBUF(SZ) 

C 

C  CHECK  EXISTENCE  OF  SFF  FILE 
C 

IF(JBUF(31)  .EQ.  BLANKS)  THEN 
URITE(IUR,802)  FILTYP(4) 

CALL  CLSFIL(LUSO,MXFS) 

GO  TO  100 
ELSE 

URITE(SFFN,30)  (JBUFd ), I-31.30+NUFN) 

CALL  CKFILE(IWR,1.SFFN,4,LUS,LUS0,FILTYP,NZS,IST) 

IFdST  .NE.  0)  THEN 

CALL  CLSFIL(LUSO,MXFS) 

GO  TO  100 
ENOIF 
ENOIF 
C 

C  CHECK  IF  SOUND  VELOCITY  OUTPUT  IS  REQUIRED 
C 

IF(JBUF(41)  .EO.  BLANKS)  THEN 
URITEdUR,1302)  FILTYP(5) 

1302  FORMAT(2X,A4,'FILE  NAME  IS  NOT  DEFINED  -  NO  SOUND  VELOCITY  >, 

•  'OUTPUT') 

ELSE 

URITE(SVFN,30)  ( JBUFd ), I>41,40+NWFN) 

CALL  CKFILEdUR,2.SVFN,5,LUS,LUSO.FILTYP.NZS,IST) 

IFdST  .EQ.  -1)  THEN 
CALL  CLSFILCLUSO.NXFS) 

GO  TO  100 
ENOIF 
ENOIF 
C 

C  CHECK  IF  TEMPERATURE  OUTPUT  IS  REQUIRED 
C 

IF(JBUF(51)  .EQ.  BLANKS)  THEN 
URITEdUR.1304)  FILTYP(6) 

1304  F0RMAT(2X,A4,'FILE  NAME  IS  NOT  DEFINED  -  NO  TEMPERATURE  ', 

*  'OUTPUT') 

ELSE 

URITE(TFN,30)  (JBUFd),I>S1.50>NUFN) 

CALL  CKFILEdUR,2,TFN,6,LUS.LUS0.FILTYP,NZS,IST) 

IFdST  .EQ.  -1)  THEN 
CALL  CLSFIL(LUSO,MXFS) 

GO  TO  100 
ENDIF 
ENDIF 
C 

C  CHECK  IF  SALINITY  OUTPUT  IS  REQUIRED 
C 

IF(JBUF(61)  .EO.  BLANKS)  THEN 
URITEdWR,1306)  FILTYP(7) 

1306  F0RMAT(2X,A4,'FILE  NAME  IS  NOT  DEFINED  •  NO  SALINITY  OUTPUT') 
ELSE 

MITE(SFN.30)  <JBUFd),I>61,60«NWFN) 

CALL  CKFILEdMt,2,SFN,7,LUS,LUS0,FILTYP,NZS.IST) 

IFdST  .EQ.  -1)  THEN 
CALL  CLSFIL(LUSO,MXS) 

GO  TO  100 
ENDIF 
ENOIF 
C 

C  AT  LEAST  ONE  OUTPUT  IS  REQUESTED 
C 

IF(LUSVF.LE.O  .AND.  LUTF.LE.O  .AND.  LUSF.LE.O)  THEN 
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WftITE(IUR,1308) 

1308  FORMAT (2X, 'NONE  OF  THE  OUTPUT  FILE  NAMES  ARE  DEFINED',/, 

*  2X,'USE  DIRECTIVE  SF  TO  SET  AT  LEAST  ONE  OUTPUT  ', 

*  'FILE  NAI«') 

CALL  CLSFIL(LUSO,MXFS) 

GO  TO  100 

ENOIF 

WRITE(IUR,1310)  IX1,IY1,IX2,IY2 

1310  FORMAT (2X, 'TWO  END  POINTS  PREVIOUSLY  DEFINED:  ( ', 14, ' , ' , 14, 

*  ');',3X,'(',I4,',',I4,')') 

c 

C  USER  INPUTS  TWO  SETS  OF  LATITUDE  AND  LONGITUDE 
C 

URITE(IUR,1312)  MINH 

1312  FORMAT (2X, 'ENTER  LATITUDE  AND  LONGITUDE  CORRESPONDING  TO  ', 

*  'MINIMUM  H  VALUE:  ',14) 

CALL  RUI(IRO,IUR,IH,FA,IA,NVS) 

IF(NVS  .EQ.  0)  THEN 

CALL  CLSFIL(LUSO,MXFS) 

GO  TO  100 
ENOIF 

IF(IA(1).LT.-90  .OR.  IA(1).GT.90)  THEN 
UR1TE(IUR,1314) 

1314  FORMAT (2X, 'LATITUDE  MUST  BE  BETWEEN  *90  AND  90  DEGREES') 

CALL  CLSFIL(LUSO,MXFS) 

GO  TO  100 
ELSE 

IF(IA(2).LT.-180  .OR.  IA(1).GT.180)  THEN 
WRITE<IWR,1316) 

1316  F0RMAT(2X, 'LONGITUDE  MUST  BE  BETWEEN  -ISO  AND  180  DEGREES') 

CALL  CLSFIL(LUSO,MXFS) 

GO  TO  100 
ENOIF 
ENOIF 
LAT»IA<1) 

L0NG«IA(2) 

C 

C 

WRITE(IWR,1318)  MAXH 

1318  F0RMAT(2X, 'ENTER  LATITUDE  AND  LONGITUDE  CORRESPONDING  TO  ', 

*  'MAXIMUM  H  VALUE:  ',14) 

CALL  RUI(IRO,IWR,IH,FA,IA,NVS) 

IF(NVS  .EQ.  0)  THEN 

CALL  CLSFIL(LUSO,MXFS) 

GO  TO  100 
ENOIF 

IF(IA(1).LT.-90  .OR.  IA(1).GT.90)  THEN 
WRITE(IWR,1314) 

CALL  CLSFIL(LUSO,MXFS) 

GO  TO  100 
ELSE 

IF(IA(2).LT.-180  .OR.  IA(2).GT.180)  THEN 
WRITE(INR,1316) 

CALL  CLSFIL(LUSO,MXFS) 

GO  TO  100 
ENOIF 
ENDIF 
LAT2-IA(1) 

L0NG2*IA(2) 

C 

C  READ  IN  TEMPERATURE  AND  SALINITY  PROFILES  AT  THESE  TWO  LOCATIONS 
C 

CALL  RDTS(LUDBF , LONG, LAT , TEMP, SAL , 180,XDBF ) 

CALL  ROTS( LUDBF , L0NG2, LAT2, TENP2, SAL2. 180,X08F ) 

C 

C  FIND  THE  POINTS  BETWEEN  TWO  END  POINTS 
C 

CALL  OLXYC 1X1 , IY1 ,1X2, IY2,MPTS,MXVS, IXS, ITS) 

C 
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C  COMPUTE  SIGMA  PROFILES  AT  THESE  TUO  LOCAITONS 
C 

DO  i320  I>1,NZS 
DEP<I)*(I-1)*I2 
DEP02(I)>«EP(I) 

1320  CONTINUE 

CALL  INTRPL(IWR,MXZS,ZLEV,TEMP,N2S,DEP02, TEMPO) 

CALL  INTRPL(!WR,NXZS,ZLEV,SAL.NZS,0EPO2,SAL0) 

CALL  INTRPL(IWR,MXZS,ZLEV.TEMP2,NZS,0EPO2.TEHPO2) 

CALL  INTRPL(IUR.HXZS,ZLEV.SAL2,NZS.DEP02.SAL02) 

PR*0. 

00  1322  I»1,MZS-1 

BVF0( I )>8VFRQ(SAL0( 1 ) , TENP0( I ) ,0EP02( I ) ,2.PAV.EE) 
BVF02( I )>BVFRQ(SAL02( I ) ,TEMP02( I ) .DEP02( I ),2.PAV,EE) 
0UM>SVAN(SAL0(1 ).  TENPOd  ),PR,SIG0(  1 }) 

DUM>SVAN ( SAL02( I ) , TENP02( I) . PR , S I G02( I ) ) 

1322  CONTINUE 

BVF0(NZS)>BVF0(NZ$-1)'»(BVF0(NZS-1)-BVF0(NZS-2)) 

BVF02(NZS)-BVF02(NZS-1)'»(BVF02(NZS-1)-BVF02(NZS'2)) 

OUN>SVAN<SALO(NZS),TENPO(N2S}.PR.SIGO(NZS» 

DUM>SVAN ( SAL02 ( NZS ) , TEMP02 ( NZS ) . PR . S I G02( NZS ) ) 

CALL  SIGINT(IZ,NZS,BVFO,SIGO) 

CALL  SIGINT(IZ.NZS,BVF02,SIG02) 


WRITE! IWR, 1330)  FILTYP(4),SIGMIN.SIGMAX.LAT.L0NG,SIG0(1). 

*  SlGO(N2S),LAT2,L0NG2,SIGO2(1),SIGO2(NZS) 
1330  FORMAT! 

*2X,<NIN/MAX  SIGMA  VALUES  FOUND  IN  '.A4,<  FILE:  ‘.FIO.S,', 

*  F10.5./, 

*2X.'MIN/MAX  SIGMA  VALUES  FOUND  AT  LAT  ‘,I4,>,  LONG  '.14,' 

*  FIO.S,', '.FIO.S,/, 

*2X.'MIN/MAX  sigma  values  found  at  LAT  ',14.',  LONG  ',14,' 

*  FIO.S,', '.FIO.S) 

SIGMIN«AMIN1!SIGMIN,SIG0!1),SIG02!1)) 

S I GMAX>AMAX1 ! S I GMAX , S I GO! NZS ) , S I G02!NZS ) ) 

EXTRAPOLATE  TEMPERATURE,  SALINITY,  SIGMA  DATA 

MZS>IABS!MINH)/IZ>1 
DO  1340  I«NZS,1,-1 

TEMPO!MZS»I)«TEMPO!I) 

TEMPOZIMZS-^I  )«TEMP02!  I ) 

SAL0!NZS'»I)>SAL0!1} 

SAL02!MZS*I)>SAL02!I) 

SIGOIMZS-^D-SIGO!!) 

SIG02!MZS«I)«SIG02!I) 

1340  CONTINUE 

OTO-TEMPO!MZS«2 ) - TENP0!MZS*1 ) 

DT02«TEMP02!MZS+2 ) - TEMP02!NZS« 1 ) 
0S0-SAL0!NZS«2)-SAL0!NZS>1 ) 

DS02-SAL02!MZS4'2)-SAL02!NZS4-1  ) 
DSIG0«!SIG0!MZS*1)-SIGMIN)/MZS 
IF!DSIG0  .EO.  0.)  DSIGO-.OOOOOS 
OSIG02-!SIG02!NZS«1)-SIGMIN)/MZS 
IF!0SIGO2  .EO.  0.)  DSIGO2-.00000S 
DO  1342  I-MZS,1,-1 

TEMPO! I )»TEMPO! 1+1 ) -DTO 
TEMP02! I )*TEMP02! I>1 ) -OTOE 
SALO!I)-SALO!I'»1)-OSO 
SAL02! I )-SAL02! 1^1 )-0SO2 
SIGO!I)-SIGO!I«1)-OSIGO 
SIG02!  I  )>SIG02!I«1  }-0SIGO2 
1342  CONTINUE 
J«MZS>NZS 

M2S>IABS!NAXH)/IZ«1 
DTO-TEMPO! J )- TEMPO! J - 1 ) 

0TO2-TEMPO2! J)-TEMP02! J- 1 ) 

OSO>SALO! J ) - SALO! J- 1 ) 
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DS02-SAL02( J ) - SAL02( J - 1) 

OS I GO- ( S I GMAX - S I G0( J ) )/MZS 
IF(DSIGO  .EG.  0.)  OS1GO-. 000005 
OS 1 G02-( S I GMAX - S I G02( J ) )/MZS 
IF(0SIGO2  .EG.  0.)  OSIGOZ-.OOOOOS 
00  1344  I-1,MZS 

TEMPO( 1 )»TEMPO<  J* I  - 1 )+0T0 
TEMP02(  J->I  )»TEMPOZ(  J*I  - 1  )+0T02 
SALO(  J*  I  )>SALO(  1  •  1  )'K>SO 
SAL02(  J*  I  )>SAL02(  J-^I  -  D'fOSOZ 
SIGOOD-SIGOOI-D+OSIGO 
S I  G02(  J-^  I  )-S  I  G02(  J>I  •  1  l-KISl  G02 
1344  CONTINUE 
HZS-J'HtZS 

StGMIN>AMIN1(SIGMIN,SIG0(1).SIG02(1)) 

S I GMAX-AMAX 1 ( S I GMAX , S I G0( MZS ) , S I G02 ( NZS ) ) 

KZS»M2S*1.5 
IF(KZS  .GT.  MXVS)  THEN 
MITE(IUR,1346} 

1346  FORMAT (2X, 'TOO  MANY  UOROS  REGUIREO  TO  PERFORM  INTERPOLATION') 
CALL  CLSFIL(LUSO,NXFS) 

GO  TO  100 
ENOIF 
C 

C  COMPUTE  OELTA  SIGMA  8ASE0  UPON  MINIMUM  SIGMA  ANO  MAXIMUM  SIGMA  VALUES 
C 

OELSIG>(SIGMAX-SIGMIN)/(KZS-1) 

00  1348  I-I.KZS 

SIG2(I)«SIGMIN-»(I-1)*0ELSIG 
1348  CONTINUE 
C 
C 

CALL  INTRPLdUR, MZS, SIGO,TEMPO,K2S,SIG2, TEMP) 

CALL  INTRPL<IM,MZS,SIG02.TEMP02.KZS,SIG2.TEMP2) 

CALL  INTRPLdUR, MZS,SIG0.SAL0,KZS.SIG2.SAL) 

CALL  INTRPLdUR, MZS, SIG02,$AL02,KZS,S1G2,SAL2) 

C 

C  COMPUTE  TEMPERATURE  ANO  SALINITY  FIELOS  BASEO  UPON  SIGMA 
C 

PR-0. 

IREC-0 

00  1390  I-1,MPTS 

REAO(LUSFF,REC«I)  (SIG(J), J«1,NZS) 

CALL  LINTPLdUR,NZS,SIG,OEP,KZS,SIG2,OEPO,INOEX) 

IFdREC  .NE.  IXSd))  THEN 
IREC-IXSd) 

REAO(LUNMF,REC-IREC)  (GdREC, J), J-1,MXR0US) 

ENOIF 

0V-adREC,IYSd)) 

0E1-(MAXH-0V)**E 
0E2-(0V-NINH)**E 
0E12-GE1«GE2 
DO  1358  J>1,KZS 

TEMPO( J )-(0E 1 •TEMPC J )4GE2*TEMP2( J ) )/0E 12 
SALO< J )-(0E1*SAL( J )«GE2*SAL2( J ) )/0E12 
1358  CONTINUE 

CALL  INTRPLdUR,KZS,0EPO,TEMPO,NZS,0EPO2,TENPO2) 

CALL  INTRPLdUR, KZS,0EPO,SALO,NZS,0EPO2,SALO2) 

C 

C  CHECK  IF  RECOMPUTING  SIGMA  FIELO  IS  NECESSARY 
C 

IFdRCF.EG.YES(l)  .OR.  IRCF.E0.YES(2))  THEN 
00  1364  J-1,NZS 

0UM-SVAN(SALO2(J),TEMPO2(J),0EPO2(J),SIGO2(J)) 

1364  CONTINUE 

ISUAP-O 

DO  1370  J-1,N2S-1 
00  1368  K-J«1,NZS 

1F(SIG02(J)  .GT.  SIG02(K))  THEN 
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IFCISUAP  .EO.  0)  ISWAP^J 
S>SIG02(J) 

SIG02(J)=SIG02(K) 

SIG02(K}xS 

SxTEMP02(J) 

TEMP02(J)xTEMP02(K) 

TEMP02(K)xS 

SxSAL02(J) 

SAL02(J)xSAL02<K} 

SAL02(K)xS 
END  IF 

1368  CONTINUE 

1370  CONTINUE 

IFCISUAP  .GT.  0)  THEN 

URITE(IUR.1372)  IXS(I}.IYS(I),0EPO2(ISUAP) 

1372  FORHAT(2X, 'RECOMPUTED  SIGMA  AT  X,Y;  ',14,', '.14, 

*  ■  IS  OUT  OF  SEQUENCE  STARTING  AT  DEPTH:  '.FS.O) 

END  IF 
ENDIF 
C 

C  WRITE  OUTPUT  DATA  TO  DISC 
C 

IFCMOOCI.SO)  .EO.  0)  URITE(IUR,1252)  I.MPTS 
IFCLUSVF  .GT.  0)  THEN 
DO  1380  Jxl.NZS 

SVC J )«SVEL ( SAL02( J ) . TEMP02( J ) , DEP02( J ) ) 

1380  CONTINUE 

URITECLUSVF,REC«I)  CSVCJ), J«1,N2S} 

EWIF 

IFCLUTF  .GT.  0)  URITECLUTF.REC>1 )  CTEMP02CJ), J^I.NZS) 

IFCLUSF  .GT.  0)  URITECLUSF.RECxI )  CSAL02CJ),J>1.NZS) 

1390  CONTINUE 

IFCMODCMPTS.SO)  .NE.  0)  URITECIUR,12S2)  MPTS.MPTS 
CALL  OATIMECtN.IA.lSEC) 

IFCLUSVF  .GT.  0)  THEN 
J8UFC414>NWFN)>IHC1) 

JBUFC424^NUFN)xIHC2) 

J8UFC434'NUFN)>IAC1) 

J8UFC44«NWFN)<(AC2} 

ENDIF 

IFCLUTF  .GT.  0)  THEN 
JBUFCSUNWFNIxIHCD 
JBUFC52>NUFN)>IHC2} 

JSUFC53^NWFN)«IAC1) 

JBUFC54«NWFN)*IAC2} 

ENDIF 

IFCLUSF  .GT.  0)  THEN 
JBUFC61>NUFN)xIHC1) 

JBUFCGZ^NUfNIalNCZ) 

J8UFC63^NUFN)«IAC1) 

JBUFC64>NUFN)xIAC2) 

ENDIF 

CALL  CLSFILCLUSO.MXFS) 

URITECLUCF,REC-2)  CJBUFCI). I-1,NUPRCF) 

GO  TO  100 
C 

C  END  -  END  THE  PROGRAM 
C 

9000  CLOSECUNITxLUCF.STATUS-'KEEP') 

STOP 

END 


C 


C  SUBROUTINE:  INPAR 

C  THIS  SUBROUTINE  INITIALIZES  ALL  THE  PROCESSING  PARAMETERS  TO 

C  DEFAULT  VALUES 

C  IPARC11):  NUMBER  OF  POINTS  USED  FOR  FRONT  CURVE  CNPTS) 

C  IPARC12):  NUMBER  OF  POINTS  USED  TO  PERFORM  SMOOTHING  FUNCTION  CLM) 

C  PARC15):  RIPPLE  POWER  CRLP) 
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C  IPAR(U):  NUMBER  OF  ITERATION  (ITER) 

C  PAR(21):  RELAXATION  COEFFICIENT  (ALFA) 

C  PAR(22):  ROSSBY  DEFORMATION  RADIUS  (BETA) 

C  PAR(23):  H  GRID  SPACING  (H) 

C  IPAR(24):  MAXIMUM  H  VALUE  (MAXH) 

C  IPAR(25):  MINIMUM  H  VALUE  (HINH) 

C  IPAR(26):  NUMBER  OF  ITERATION  (JTER) 

C  IPAR(31):  LATITUDE  OF  DESIRED  LOCATION  (LAT) 

C  IPAR(32):  LONGITUDE  OF  DESIRED  LOCATION  (LONG) 
C  IPAR(33):  DEPTH  INCREMENT  (IZ) 

C  PAR(S1):  EXPONENT  VARIABLE  (E) 

C  IPAR(S2):  RECOMPUTE  SIMGA  FIELD  FLAG  (IRCF) 


C 

SUBROUTINE  INPAR(MXFCPS, IPAR) 

INTEGER*4  IPAR(*) 

EQUIVALENCE  (IV,FV) 

DATA  N0/4HN  / 

C 

C 

IPARdD^FCPS 

IPAR(12)>10 

FV»2. 

IPAR(13)>IV 

IPAR(14)>20 

FV=1.7 

IPAR(21)aIV 

FV»20. 

IPAR(22)«IV 

FV=.4 

IPAR(23)>IV 

IPAR(24)>100 

IPAR(2S)«-100 

IPAR(26)>1000 

IPAR(31)a30 

IPAR(32)»-70 

IPAR(33)s10 

FV*1. 

IPAR(S1)sIV 

IPAR(52)-NO 

RETURN 

END 

C 

Q**************************************'********************************** 


C  SUBROUTINE:  SETFS 

C  THIS  SUBROUTINES  ALLOWS  THE  USER  TO  SET  UP  REQUIRED  INPUT 

C  AND  OUTPUF  FILES 

c 

SUBROUTINE  SETFS(IRO,IUR,NWFN,IBUF,IH,FA,IA,IST) 

PARAMETER  (N0IRS>10) 

INTEGER*4  BLANKS, IBUF(*), IH(*), IA(*), IDIRS(NOIRS) 

REAL  FA(*) 

DATA  BLANKS/4H  / 

DATA  IDIRS/4HLD  ,4HLF  ,4HEX  ,4HEND  ,4HDBF  .4HHNF  ,4HSFF  , 

*  4HSVF  ,4HTF  ,4HSF  / 

C 

C  LD 
C 

10  WRITE(IWR,20)  (IDIRS(I),I>1,NOIRS) 

20  FORMAT! 

•2X,A4,'»  LIST  SF  DIRECTIVES',/, 

*2X,A4,'«  LIST  FILE  NAMES',/, 

*2X,A4,'«  EXIT  FROM  DIRECTIVE  SF',/, 

*2X,A4,'-  END  THE  PROGRAM',/, 

*2X, '**•**  AVAILABLE  FILE  TYPES  ***•*',/, 

*2X,A4,'-  LEVITUS  DATABASE  REQUIRED  BY  DIRECTIVES  TS  AM)  SV  ', 

*  'AS  INPUT',/, 

*2X,A4,'>  Q  MATRIX  FILE  OUTPUT  BY  DIRECTIVE  HELM',/, 
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*2X,A4,'«  SIGMA  FILE  OUTPUT  BY  DIRECTIVE  SIG',/, 

*2X,A4,'»  SOUMO  VELOCITY  FILE  OUTPUT  BY  DIRECTIVE  SV'./, 
*2X,A4,'»  BLENDED  TEMPERATURE  FILE  OUTPUT  BY  DIRECTIVE  SV,/, 
*2X,A4,*»  BLENDED  SALINITY  FILE  OUTPUT  BY  DIRECTIVE  SV) 

30  WRITE! lUR, 40) 

40  F0RNAT(2X, 'ENTER  SF  SUBOIRECTIVE  NAME') 

CALL  RUI(IRD,IUR,IH,FA,IA,NVS) 

DO  50  IG0«1,N0tRS 

IF(IH(1)  .EG.  lOIRS(IGO))  GO  TO  100 
50  CONTINUE 

WRITE! lUR, 60) 

60  F0RMAT!2X,' INVALID  SF  SUBOIRECTIVE') 

GO  TO  30 
C 
C 

100  IF!IGO  .GT.  4)  THEN 

WRITE!IWR,102)  IDIRS!IGO) 

102  F0RMAT!2X, 'ENTER  ',44, '  FILE  NAME') 

CALL  RUI!IRD,IUR,IH,FA,IA,NVS) 

ENOIF 

GO  TO  !10,110, 900,900,120,130,130,130,130,130), IGO 
C 

C  LF 
C 

110  WRITE!IWR,112)  I0IRS!5),!IBUF!I),Ia1,12) 

112  F0RMAT!2X,A4,'»  ',1244) 

WRITE!IWR,114)  I0IRS!6),!IBUF!I),I»21,20+NWFN*4) 

114  F0«MAT!2X,A4,'»  ',6A4,T33, 'LAST  WRITTEN  TIME:  ',244,'  *,244) 

WRITE!IWR.114)  I0IRS!7),!IBUF!I),I«31,3!KNWFN+4) 
WRITE!IWR,114)  IOIRS!8),!I8UF!I),I«41,40+MWFN+4) 
WRITE!IWR,114)  IDIRS!9),!IBUF!I),I«51,5!)»MWFN*4> 
MRITE!IWR,114)  IOIRS!lO),!IBOF!I),I»61,60+NWFN*4) 

GO  TO  30 
C 

C  SET  DBF  FILE  NAME 
C 

120  DO  124  I>1,12 

IBUF!I)«IH!I) 

124  CONTINUE 
GO  TO  30 
C 

C  SET  HMF,SFF,SVF,TF,SF  FILE  NAME 
C 

130  IFLAG>0 

J»!IGO-6)*!NWFN+4)+20 
DO  132  I>1,NWFN 

IF!IBUF!J«I)  .NE.  IH!I))  THEN 
IBUF!J*I)>IH!I) 

I  FLAG-1 
ENDIF 
132  CONTIMC 

IF!IFLAG  .EQ.  1)  THEN 
DO  134  1-1,4 

IBUF!  J-HMFIKI  )-BLANKS 
134  CONTINUE 
ENOIF 
GO  TO  30 
C 

C  EX.  END 
C 

900  IF! IGO  .EQ.  3)  THEN 
I  ST-0 
ELSE 
1ST— 1 
ENOIF 
RETURN 
END 
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C  SUBROUTINE:  SETPAR 

C  THIS  SUBROUTINES  ALLOWS  THE  USER  TO  SET  UP  ALL  REQUIRED 

C  PROCESSING  PARAMETERS 


C 


C 

C 


10 

20 


30 


40 

50 


SUBROUTINE  SETPAR( IRD, IWR.HXFCPS, IPAR, IH, FA, lA, 1ST) 
PARAMETER  (NDIRS>19) 

INTEGERS  YES(2), IPARC*), IH(*), IA(*), IDIRS(NDIRS) 

REAL  FA(*) 

EQUIVALENCE  (IV,FV) 

DATA  IDIRS/4HLD  ,4HLP  ,4HEX  ,4HEND  ,4HNPTS,4HLN  .4HRLP  , 

•  4HITER,4HALFA,4HBETA,4HF  ,4HMAXH,4HNINH,4HJTER, 

*  4HLAT  ,4HL0NG,4HIZ  ,4HE  ,4HRCF  / 

DATA  YES/4HY  ,4HYES  / 


NPTS>IPAR(11) 

LM>IPAR(12} 

IV«IPAR(13) 

RLP>FV 

ITER«IPAR(14) 

IV-IPAR(21) 

ALFA*FV 

IV>IPAR(22) 

BETA>FV 

IV-IPAR(23) 

H>FV 

MAXH>IPAR(24) 

MINH«IPAR(25) 

JTER>IPAR(26) 

LAT>IPAR(31) 

L0NGaIPAR(32) 

IZ>IPAR(33) 

IV*IPAR(S1) 

EaFV 

IRCF*IPAR(52) 

URITE(IUR,20)  (IDIRS(I),I»1,8) 
FORMAT ( 

*2X,A4,' 

•2X,A4,' 

•2X,A4,' 

•2X,A4,' 

*2X, 

*2X,A4, 


LIST  SP  SUBOIRECTIVES',/, 

LIST  PARAMETERS',/, 

EXIST  FROM  SP  DIRECTIVE',/, 

END  THE  PROGRAM',/, 

AVAILABLE  PARAMETERS  ******',/, 

•  >  NUMBER  OF  POINTS  USED  TO  GENERATE  FRONT  CURVE  ', 
'(FRNT)'  / 

*2X,A4,'  ■  NUMBEr'oF  POINTS  <-/♦)  TO  SAMPLE  (FRNT)',/, 

•2X,A4,'  >  RIPPLE  POWER  (FRNT)',/, 

•2X,A4,'  «  NUMBER  OF  ITERATIONS  USED  TO  GENERATE  FRONT  CURVE  ', 

*  '(FRNT)') 

URITE(IWR,30)  (I0IRS(I),I»9,N0IRS) 

FORMAT ( 

*2X,A4,'  -  RELAXATION  COEFFICIENT  (HELM)',/, 

•2X,A4,'  >  ROSSBY  DEFORMATION  RADIUS  (HELM)',/, 

*2X,A4,'  >  H  GRID  SPACING  (HELM)',/, 

*2X,A4,'  -  MAXIMUM  H  VALUE  (HELM)',/, 

*2X,A4,'  >  MINIMUM  N  VALUE  (HELM)',/, 

•2X,A4,'  ■  NUMBER  OF  ITERATIONS  APPLIED  TO  HELM  SOLVER  (HELM)',/, 
•2X,A4,'  ■  LATITUDE  OF  DESIRED  LOCATION  IN  DEGREES(TS)',/, 

•2X,A4,'  >  LONGITUDE  OF  DESIRED  LOCATION  IN  DEGREES  (TS)',/, 
•2X,A4,'  >  DEPTH  INCREMENT  (TS)',/, 

•2X,A4,'  -  EXPONENT  VARIABLE  (SV)',/, 

•2X,A4,'  ■  FLAG  (Y/N)  INDICATING  NECESSITY  OF  RECOMPUTING  SIGMA  ', 

*  'FIELD  (SV)',/, 

•2X,4X,'  NEW  SIGMA  FIELD  WILL  BE  SORTED  IN  ASCENDING  ORDER',/, 
•2X,4X,'  BLENDED  TEMPERATURE  AND  SALINITY  VALIXS  WILL  BE  SORTED 

*  'ACCORDINGLY') 

URITE(IWR,50) 

F0RMAT(2X, 'ENTER  SP  SUBDIRECTIVE  NAME') 

CALL  RUI(IRD,IWR,IH,FA,IA,NVS) 
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DO  60  1G0>1,N0IRS 

IF(IH(1)  .EQ.  IDIRS(IGO))  GO  TO  100 
60  CONTINUE 

URITE(IWR,70) 

70  FORNAT(2X,' INVALID  SP  SUBDIRECTIVE') 

GO  TO  40 


C 

C 

100 


102 


C 

C  LP 
C 

110 


112 


IF(((IGO.GT.4  .AND.  IGO.LT.tffllRS)  .AND.  NVS.EG.O)  .OR. 

•  (IGO.EQ.NDIRS))  THEN 
URITE(IUR.102)  IDIRS(IGO) 

FORNAT(2X, 'ENTER  VALUE  FOR  PARAMETER  '.A4) 

CALL  RUI(IRD,IUR,IH,FA,IA,NVS) 

ENDIF 

GO  TO  (10,110,900.900.120.130,140,150,160.170,180,190,200,210,220, 

•  230,240,250,260), IGO 


URITE(IUR,112)  I0IRS(5),NPTS,I0IRS(6),LN,I0IRS(7),RLP, 
•  IDlRSf . t TER . ID tBS(9) . ALFA. IDIRSf 101 .B 


• 

I0IRS(8). ITER, I0IRS(9), ALFA, IDIRS(IO), BETA, 

• 

IDIRS<11).F,IDIRS(12),MAXH,IDIRS(13),N1NH, 

• 

IDIRS(14),JTER,I0IRS(15),LAT.IDIRS(16),L0NG 

• 

I0IRS(17).IZ,I0IRS(18),E,IDIRS(19),IRCF 

FORMAT( 

•2X.A4,' 

a 

',I4.T31.A4.'  «  ',14./, 

•2X,A4,' 

a 

'.F10.5,T31,A4.'  »  '.14,/, 

*2X,A4, ' 

a 

',F10.5,T31,A4.'  «  ',F10.5,/, 

*2X,A4,' 

a 

'.F10.5./. 

*2X,A4,' 

a 

',I4,T31.A4.'  »  '.14./. 

*2X,A4,' 

a 

',14,/, 

*2X,A4.' 

a 

',I4.T31,A4,'  »  '.14,/, 

*2X,A4,' 

a 

'.14,/, 

*2X,A4,' 

a 

',F10.5,T31,A4,'  «  ',A4) 

GO  TO  40 


C 

C  NPTS 
C 

120  IF(IA(1)  .LE.  1000)  THEN 
URITE<IUR,122) 

122  FORMAT(2X, 'NPTS  CANNOT  BE  <  1000') 
ELSE 

IF(IA(1)  .GT.  MXFCPS)  THEN 
MtITE(IUR,124)  MXFCPS 

124  FORMAT(2X,'NPTS  CANNOT  BE  >  ',14) 

ELSE 

NPTS»IA<1) 

ENDIF 
ENDIF 
GO  TO  40 


C 

C  LM 
C 

130  LN>IA(1) 
GO  TO  40 
C 

C  RLP 
C 

140  RLP>FA(1) 
GO  TO  40 


C 

C  ITER 
C 

150  ITER>IA(1) 
GO  TO  40 
C 

C  ALFA 
C 

160  ALFA-FA(I) 


40 


GO  TO  40 


C 

C  BETA 
C 

170  BETA>FA(1) 

GO  TO  40 
C 

C  H 
C 

180  H>FA(1) 

GO  TO  40 
C 

C  MAXH 
C 

190  NAXH>IA(1) 

GO  TO  40 
C 

C  MINH 
C 

200  NINH>IA(1) 

GO  TO  40 
C 

C  JTER 
C 

210  JTER>IA(1) 

GO  TO  40 
C 

C  LAT 
C 

220  IF(IA(1).LT.-90  .OR.  IA(1).GT.90)  THEN 

URITEdUR  222) 

222  FORMAT(2x|<UTITUDE  MUST  BE  BETWEEN  -90  AND  90  DEGREES') 
ELSE 

LAT>IA(1) 

ENOIF 
GO  TO  40 
C 

C  LONG 
C 

230  1F(IA<1).LT.-180  .OR.  IA(1).GT.180)  THEN 

URlTEdWR  232) 

232  FORttAT(2x) 'LONGITUDE  NUST  BE  BETWEEN  -180  AND  180  DEGREES') 
ELSE 

LONG«IA(1) 

ENOIF 
GO  TO  40 
C 

C  IZ 

c 

240  IZ>IA(1) 

GO  TO  40 
C 

C  E 
C 

250  E«FA(1) 

GO  TO  40 
C 

C  IRCF 
C 

260  IRCF>IN(1) 

GO  TO  40 
C 

C  EX,  END 
C 

900  IFdGO  .EO.  3)  THEN 
IPAR(11)>NPTS 
IPAR(12)>LN 
FV«RLP 
IPARd3)«IV 
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tPAR(U)sITER 

FV-ALFA 

IPAR(21)>IV 

FV>BETA 

1PAR(22)>1V 

FV=H 

IPAR(23)3lV 

IPAR(2A)«MAXH 

IPAR(2S)=MINH 

IPAR(26)«JTER 

IPAR(31)»LAT 

IPAR:32)«L0N6 

IPAR(33)>IZ 

FV»E 

IPAR<S1)«IV 

IPAR(52)-IRCF 

IST»0 

ELSE 

IST»-1 

ENOIF 

RETURN 

END 

C 


C  SUBROUTINE:  ROTS 

C  THIS  SUBROUTINE  READS  TEMPERATURE  AND  SALINITY  PROFILES  AT 

C  A  GIVEN  LONGITUDE  AND  LATITUDE  LOCATION  FROM  LEVITUS  DATABASE 


C 


SUBROUTINE  ROTS(LUOBF, LONG, LAT. TEMP, SAL, NUPR.XDBF) 
REAL  XOBF(*),TEMP(*),SAL(*) 

C 

C 

I«LAT>90 

IF(L0NG  .LT.  0)  THEN 
J>L0NG«360 
ELSE 
J«LONG 
ENDIF 
J»J/5*1 
I»I/5>1 

IREC»<J-1)*1U*I*72 

REAO( LUDBF , REC> I REC )  (XOBF( I ) , I >1 , NUPR } 

C 

C  CHECK  FOR  0  OBERSERVATION  (-999  IS  INSERTED) 

C 

DO  100  I«1,30 
J-(I-1)*3+1 

IF(XOBF(J)  .LE.  .1)  THEN 
TEMP(I)a-999. 

ELSE 

TEMP(I)-XDBF(J-»1) 

ENOIF 

IF(XDBF(J«90)  .LE.  .1)  THEN 
SAL(n>-999. 

ELSE 

SAL(I)-)(DBF(J^1) 

ENOIF 
100  CONTINUE 
C 
C 

DO  200  Ia2,30 

IF(TEMP(I)  .LE.  -996.)  TENP(I)-TENP(l-1) 
IF(SAL(I)  .LE.  -998.)  SAL(I)aSAL(I-1) 

200  CONTINUE 
RETURN 
END 
C 
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C  SUBROUTINE:  SIGINT 

C  THIS  SUBROUTINE  INTEGRATES  SIGNA  VALUES 


C 

SUBROUTINE  SIGINT(IZ,NZS,BVF,SIG) 
REAL  BVF{*),SIG(*) 

C 

c 

FACT0R«(2.*3. U16)**2/(3600.**2) 
G-9.8 


I0XMAX>1 

BVFIUX>BVF(ID)(MAX) 

DO  10  I>2,NZS 

IF(BVF(I)  .GT.  BVFMAX)  THEN 
lOXNAX-I 
BVFMAX>BVF(I) 

EWIF 
10  CONTINUE 
C 
C 

S>SI6(I0XMAX) 

RHO>S>1000. 

C>RHO/G 

BVFSUM*0. 

DO  20  I>IDXMAX-1,1,-1 

BVF2«(BVF( I )>BVF( I«1 ))/2. 
RN»<BVF2**2)*FACT0R 
BVFSUM>BVFSUN«RN*IZ 
SIG<I)*S-(C*BVFSUN) 

20  CONTINUE 

C 

C 

SIG(IDXMAX)«S 

C 

c 

BVFSUMsO. 

DO  30  I«IDXNAX«1,NZS 

BVF2«(BVF( I )+BVF< I - 1 ) )/2. 
RN»<BVF2**2)*FACTOR 
BVFSUM-BVFSUM-RN*IZ 
SIG(I)»S*(C*BVFSUM) 

30  CONTINUE 
RETURN 
END 


C 


C  SUBROUTINE:  LINTPL 

C  THIS  SUBROUTINE  PERFORMS  LINEAR  INTERPOUTION.  LINEAR 

C  EXTRAPOLATION  ON  BOTH  ENOS  IF  REQUEST  DATA  IS  NOT  WITHIN 

C  INPUT  DATA  RANGES 


C 

SUBROUTINE  LINTPL(INR,L,X,r,N,U,V, INDEX) 
INTEGERS  INOEX(*) 

REAL  X{*),Y(*).U<*),V<*) 

C 

C 

DO  50  I>2,L 

IF(X(I-1)  .EQ.  X(I))  Tt«N 


URITEdUR.IO) 

10 

F0RMAT(2X. 'LINTPL:  IDENTICAL  X  VALUES') 
URITE(IUR,20)  I,X(I) 

20 

F0RMAT(2X,'  I: 

URITE(IWR,30)  L,N 

',I7,5X,'X<I)  •  ',E12.3) 

30 

F0RMAT(2X, 'LINTPL  L: 
RETURN 

ELSE 

',I7,5X,'N  -  ',17) 
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IF(X(I-1)  .GT.  X(I))  THEN 
WRlTE(lMt,40) 

40  FORMAT(2X,aiNTPL:  X  VALUES  OUT  OF  SEQUENCE') 

UR1TE(1WR.20)  I,X(I) 

WRITE(1WR,30)  L,N 
RETURN 
END  IF 
ENOIF 
SO  CONTINUE 
C 
C 

DO  100  I>1.N 

IF(U(I)  .GE.  X(1))  GO  TO  120 
100  CONTINUE 
C 
C 

120  ISTARTsI 

DY»Y(2)-Y(1) 

DO  130  IxISTART-1,1.-1 
V(I)»Y<1)-(ISTART-I)»0Y 
130  CONTINUE 
C 
C 

DO  140  I>1,LH 
IN0EX(I)>0 
140  CONTINUE 
C 
C 

J«1 

DO  160  I>ISTART,N 
IBP>J 

DO  ISO  J-I8P,L*1 

IF(U(I}.GE.X(J)  .AND.  U(I).LE.X(J>1))  THEN 
42«<J-1)*2+1 

IF(INDEX(J2)  .LE.  0)  INOEX(J2)«I 
INDEX(J2«1)aI 
GO  TO  160 
ENOIF 

ISO  CONTINUE 
160  CONTINUE 
C 
C 

DO  180  J«1,L*1 
J2a<J-1)*2*1 

IF(INOEX<J2)  .HE.  0)  THEN 
IBP>IN0EX(J2) 

IEP-IN0EX(J2>1) 

0Y»T<J+1)-Y<J) 

0X>X(J^1)-X(J) 

DO  170  I>IBP,IEP 
OX1>U(I)-X(J) 

R>OX1/DX 
V<I)«YCJ>*R*OY 
170  CONTINUE 

ENOIF 
180  CONTINUE 
C 
C 

DO  190  I>N,1,*1 

IF(U(!)  .LE.  X(L))  GO  TO  200 
190  CONTINUE 
C 
C 

200  lENO-I 

DY«Y(L)-Y<L-1) 

DO  210  IaIENO»1,N 

V<I)aY<L)*(I-IENO)*OY 
210  CONTINUE 
RETURN 
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END 


C 

(;•••**••**••••*••*****•******•**••*•*•••••••*•*••*••************••**•••*••• 

C  SUBROUTINE:  INTRPL  (INTERPOLATION  OF  A  SINGLE  VALUED  FUNCTION) 

C  THIS  SUBROUTINE  INTERPOLATES,  FROM  VALUES  OF  THE  FUNCTION 

C  GIVEN  A  ORDINATES  OF  INPUT  DATA  POINTS  IN  THE  X-Y  PLANE  AND 

C  FOR  A  GIVEN  SET  OF  X  VALUES  (ABCISSAS),  THE  VALUES  OF  A 

C  SINGLE  VALUES  FUNCTION  YsY(X) 

C 

C  AUTHOR:  HIROSHI  AKIMA,  U.S.  DEPT.  OF  COMMERCE,  OFFICE  OF 

C  TELECOMMUNICATIONS,  INSTITUTE  OF  TELECOMMUNICATIONS  SCIENCES, 

C  BOULDER,  COLORADO  (THIS  ALGORITHM  WAS  PUBLISHED  IN  COMM.  ACM. 

C  15(10),  OCTOBER  1972 

l^************************************************************************* 

C 

SUBROUTINE  INTRPL(IUR,L,X,Y,N,U,V) 

REAL  X(*),Y(*),U(*),V(*),M1,M2,M3,N4,H5 
EQUIVALENCE  (P0,X3),(Q0,Y3),(Q1,T3) 

EQUIVALENCE  (UK,0X),(IMN,X2,A1,N1),(IMX,XS,A5,H5),(J,SW,SA), 

*  (Y2,U2,W4,Q2),(Y5,W3,Q3) 

C 

C  PRELIMINARY  PROCESSING 
C 

LOsL 

LM1»L0-1 

LH2«LM1-1 

LP1»LO*1 

N0>N 

IF(LM2  .LT.  0)  THEN 
URITE(IUR,10) 

10  FORMAT(2X,< INTRPL:  L  >  1  OR  LESS') 

URITE(IUR,20)  L0,N0 

20  FORMAT(2X,' INTRPL:  L  ■  ',I7,5X,'N  »  ',17) 

RETURN 

ELSE 

IF(N0  .LE.  0)  THEN 
URITE(IWR,30) 

30  FORMAT(2X,' INTRPL:  N  >  0  OR  LESS') 

URITE(IWR,20)  L0,N0 
RETURN 
END  IF 
END  IF 
C 
C 

DO  70  I>2,L0 

IF(X(I-1)  .EQ.  X(I))  THEN 
URITE(IUR,AO) 

40  FORMAT(2X,' INTRPL:  IDENTICAL  X  VALUES') 

WRITE(IWR,50)  I,X(I) 

50  FORMAT(2X,'  I  »  ' , I7,5X, 'X(I )  »  ■,E12.3) 

WRITE(IUR,20)  L0,N0 
RETURN 
ELSE 

IF(X(I-1)  .GT.  X(I))  THEN 
URITE(IWR,60) 

60  FORMAT(2X,' INTRPL:  X  VALUES  OUT  OF  SEQt^NCE') 

UR1TE(IMI,S0)  I,X(I) 

URITE(IUR,20)  L0,N0 
RETURN 
ENOIF 
ENDIF 
70  CONTINUE 
C 
C 

IPV»0 

DO  900  K>1,N0 
UK<4i(K) 

C 

C  ROUTINE  TO  LOCATE  DESIRED  POINT 
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c 

IF(LM2  .EQ.  0)  THEN 
1*2 

GO  TO  300 
ELSE 

1F(UK  .GE.  X(LO»  THEN 
I=LP1 
GO  TO  300 
ELSE 

IF(UK  .LT.  X(1})  THEN 
1*1 

GO  TO  300 
Et»tF 
ENOIF 
ENOIF 
IMH*2 
IMX*L0 

200  l*(lNN-^lNX)/2 

IF(UK  .LE.  X(l))  THEN 
IMX«I 
ELSE 

lMN-1+1 

ENOIF 

IF(IMX  .GT.  IMN)  GO  TO  200 
I«IMX 
C 

C  CHECK  IF  I  ■  IPV 
C 

300  IF(I  .HE.  IPV)  THEN 
IPV«I 
C 

C  ROUTINE  TO  PICK  UP  NECESSARY  X  AND  Y  VALUES  ANO  TO 
C  ESTIMATE  THEN  IF  NECESSARY 

C 

J«I 

IF(J  .EQ.  1)  J«2 
IF<J  .EQ.  LP1)  J«LO 
X3«X<J*1) 

Y3«Y(J-1) 

X4aX(J) 

Yi«Y<J) 

A3aX4-X3 
N3*<YA-Y3)/A3 
IF(LM2  .EQ.  0)  THEN 
N2-N3 
ELSE 

IF(J  .NE.  2)  THEN 
X2«X(J-2} 

Y2*Y<J-2) 

A2*X3-X2 
N2*<Y3-Y2)/A2 
IF(J  .EQ.  LO)  THEN 
NAaM3«M3*N2 
ELSE 

X5*X(4*1) 

Y5*Y<J+1) 

A4«X5-XA 

MA*<Y5-YA)/A4 

ENOIF 

ELSE 

XSaX(J«1) 

Y5*Y<4-M) 

A4>X5-XA 

NA*(Y5-YA)/AA 

N2*M3«N3-N4 

ENOIF 

ENOIF 

IF(J  .LE.  3)  THEN 
N1-N2-HI2-N3 
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ELSE 

A1«X2-X<J-3) 

M1»(Y2-Y(J-3))/A1 

ENOIF 

IF(J  .GE.  LN1)  THEN 
H5«M4^-M3 
ELSE 

A5»X(J*2)-X5 

N5»<Y(J+2)-Y5)/A5 

ENOIF 

NUMERICAL  DIFFERENTIATION 

IF(I  .EO.  LP1)  THEN 
U3«ABS(N5-MA) 

U4>ABS<M3-M2) 

IF(SW  .EQ.  0.)  THEN 
U3-.S 
U4>.S 
SU-1. 

ENOIF 

T4-(U3na'»U4*M4)/SU 

T3«T4 

SA>A2-»A3 

T4».5*(M4>M5-A2*(A2-A3)*<M2-M3)/(SA*SA)) 

X3>X4 

Y3«Y4 

A3-A2 

N3«N4 

ELSE 

U2-ABS(N4-N3) 

U3>ABS(N2-M1) 

SUaW2>va 

IF(SW  .EO.  0.)  THEN 
W2«.5 
U3-.5 
SW«1. 

ENOIF 

T3«<W2*M2+W3ni3)/SW 
IF(I  .NE.  1)  THEN 
U3«ABS(NS-M4} 

W4-*BS(M3-N2) 

SU-U3>W4 

IF(SU  .EO.  0.)  THEN 
U3-.5 
U4>.5 
SW-1. 

ENOIF 

T4»<W3*M3^*M4)/SW 

ELSE 

T4-T3 

SA>A3«A4 

T3».5*<M1+M2-A4*(A3-A4)*(M3-M4)/(SA*SA)) 

X3-X3-A4 

Y3«Y3-M2«A4 

A3-A4 

N3^ 

ENOIF 

ENOIF 

DETERMINATION  OF  THE  COEFICIENTS 

02»(2.*(M3-T3)*M3-T4)/A3 
03»< -M3-M3+T3+T4)/<A3*A3) 

ENOIF 

COMPUTATION  OF  THE  POLYNOMIAL 
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DX>UK-PO 

V(K)»a(H0X*(Q1-K)X*(Q2+0X*03) ) 
900  CONTINUE 


RETURN 

END 

C 

C******************************.**************************************** 

C  FUNCTION:  BVFRQ 

C  THIS  SUBROUTINE  CONF>UTES  BRUNT-VAISALA  FREQUENCY  IN  CPH 

C 

C  AUTHOR:  R.  MILLARD,  UOODS  HOLE  OCEANOGRAPHIC  INSTITUTION 
C 

C  NOTES:  USES  1980  EQUATION  OF  STATE 

C  UNITS: 

C  PRESSURE  PO  DECIBARS 

C  TEMPERATURE  T  DEQ  CELSIUS  (IPTS-68) 

C  SALINITY  S  <IPSS-78) 

C  BOUYANCY  FREQ  BVFRQ  CPH 

C  N**2  E  RADIANS/SECOND 

C 

C  CHECXVALUE:  BVFRQ«U. 57836  CPH  E«6.4739928E*4  RAD/SEC. 

C  S(1)»35.0,  T(1)a5.0,  P(1)=1000.0 

C  S(2)«35.0,  T<2)»4.0.  P(2)=1000.0 

C  RESULT  CENTERED  AT  PAV«1 001.0  OBARS 

C  COMPUTES  N  IN  CYCLES  PER  HOUR  AND  E-N**2  IN  RAD/SEC**2 

Q************************************************************************ 


C 

REAL  FUNCTION  BVFRQ(S,T,P,N08S.PAV.E) 
REAL  P(*),T<*),S<*) 

C 

C 

E>0. 

BVFRQaO. 

IFINOBS  .LT.  2)  RETURN 
CXX>0. 

CX«0. 

CXY-0. 

CY»0. 


c 

C  COMPUTE  LEAST  SQUARES  ESTIMATE  OF  SPECIFIC  VOLUME  ANAMOLY  GRADIENT 
C 

DO  10  K«1,N0eS 
CX«CX-»P(K) 

10  CONTINUE 

C 

C 

PAV«CX/N08S 
DO  20  Kal.NOBS 

0ATA«SVAN(S(IC),THETA<S<K),T(K),P<K),PAV),PAV,SIG)*1.0E-8 

CXY»CXY*OATA*<P(K)-PAV) 

CYaCV'fOATA 

CXX«CXX*{P<K)-PAV)**2 
20  CONTINUE 
C 
C 

IF<CXX  .EO.  0.)  RETURN 
A0«CXV/CXX 

V350P-(1 ./(SIG^IOOO. ))-DATA 

V8AR>V350PKY/N0BS 

DVDPaAO 

C 

c 

IF(V8AR  .EQ.  0.)  RETURN 

E»-  .96168423E-2^V0P/(V8AR)**2 

BVFRO>572.9578*SIGN(SQRT(ABS(E)),E) 

RETURN 

END 

C 
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FUNCTION!  SVAN 

'  SPECIFIC  VOLUME  ANGMALY  (STERIC  ANOMALY)  BASED  ON  1980  EQUATION 
OF  STATE  FOR  SEAWATER  ANO  1978  PRACTICAL  SALINITY  SCALE 

REFERENCE :MILLERO,  ET  AL  (1980)  DEEP-SEA  RES.,  27A,  PP  255-264 

MILLERO  ANO  POISSON  1981,  DEEP-SEA  RES.,  28A,  PP  625-629 
BOTH  ABOVE  REFERENCES  ARE  ALSO  FOUND  IN  UNESCO  REPORT  38  (1981) 


UNITS: 

PRESSURE 

PO 

DECIBARS 

TEMPERATURE 

T 

DEG  CELSIUS  (IPTS-68) 

SALINITY 

S 

(IPSS-78) 

SPEC.  VOL.  ANA 

SVAN 

M**3/KG*1.0E-8 

DENSITY  ANA. 

SIGMA 

KG/M**3 

CHECKVALUE;  SVAN»981 .3021  E-8  M**3/ICG  FOR  S=40  (lPSS-78) 
T>40  DEG  C,  P0«10000  DECIBARS 

SIGMA=59.82037  ICG/M«3  FOR  S=40  (IPSS-78) 

T>40  DEG  C,  P0>10000  DECIBARS 

NOTE:  R4  IS  REFERED  TO  AS  C  IN  MILLERO  ANO  POISSON  1981 


REAL  FUNCTION  SVAN(S,T,PO,SIGNA) 

REAL  K,K0,KU,K35 

EQUIVALENCE  (E,0,B1),(BU,B,R3),(C,A1,R2),(AW,A,R1),(I(U,K0,K) 
DATA  R3500/1028.1063/ 

DATA  R4/4.83UE-4/ 

DATA  0R350/28. 106331/ 

CONVERT  PRESSURE  TO  BARS  ANO  TAKE  SQUARE  ROOT  SALINITY 

P»P0/10. 

SR«SQRT(ABS(S)) 

PURE  WATER  DENSITY  AT  ATMOSPHERIC  PRESSURE 

BIGG  P.H.,  (1967)  BR.  J.  APPLIED  PHYSICS  8,  PP  521-537 

H1»((((6.536332E-9*T-1.120083E-6)*T*1.001685E-4)*T 

*  -9.095290E-3)*T*6.793952E-2)*T-28.263737 

SEAWATER  DENSITY  ATM  PRESS 
COEFFICIENTS  INVOLVING  SALINITY 
R2>  A  IN  NOTATION  OF  MILLERO  ANO  POISSON  1981 

R2«(((5.3875E-9*T-8.2467E-7)*T+7.6438E-5)»T-4.0899E-3)*T 

*  ♦8.2U93E-1 

R3>B  IN  NOTATION  OF  MILLERO  ANO  POISSON  1961 

R3«( -1 .6546€-6*T*1 .0227E-4)*T-5.72466E-3 

INTERNATIONAL  ONE-ATMOSPHERE  EQUATION  OF  STATE  OF  SEAWATER 

SIG»(R4*S'H»3*SR'H12)*S+R1 

SPECIFIC  VOLUME  AT  ATMOSPHERIC  PRESSURE 

V350P«1./R3500 
SVA— SIG*V350P/(R3S0O»SIG) 

SIGMA«SIG«OR350 

SCALE  SPECIFIC  VOL.  ANAMOLY  TO  NORMALLY  REPORTED  UNITS 

SVAN>SVA*1  .OE^ 

IF(P  .EQ.  0.)  RETURN 

C  NEW  HIGH  PRESSURE  EQUATION  OF  STATE  FOR  SEAWATER 
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C  MILLERO.  ET  AL,  1980  DSR  27A,  PP  255-264 
C  CONSTANT  NOTATION  FOLLOWS  ARTICLE 
C  COMPUTE  COMPRESSION  TERMS 
C 

E»(9.1697E-10*T+2.0816E-8)*T-9.9348E-7 
BU= ( 5 . 2787E - 8*T -6 . 1 2293E - 6)*T+3 . 4771 8£ - 5 
B=BW«'E*S 
D*1.91075E-4 

C*<-1.6078E-6*T-1.0981E-5)*T+2.2838E-3 
AW*((-5.77905E-7*T+1,16092E-4)*T*1.43713E-3)*T-. 1194975 
A*(D*SR*C)*S+AU 

B1»{-5.3009E-4*T^1.6483E-2)*T*7.944E-2 
A 1 -{ ( -6 . 1 670E - 5*T* 1 . 09987E - 2 )*T - 0 . 603459 )*T+54 . 6746 
ICWa((<-5.155288E-5*T*1.360477E-2)*T-2.327105)»T+148.4206)*T 
*  -1930.06 

K0»(B1*SR^A1)»S'»ICW 
C 

C  EVALUATE  PRESSURE  POLYNOMIAL 

C  K  EQUALS  THE  SECANT  BULK  MODULUS  OF  SEAWATER 

C  DK»K(S,T,P)-K(35,0,P) 

C  K35»K(35,0,P) 

C 

DK»(B*P-*'A)*P^K0 

K35»(5.03217E-5*P*3.359406)*P*21582.27 

GAM-P/K35 

PKal.-GAM 

SVA»SVA*PK><V350PfSVA)*P*0K/<r35*(r35+0K)) 

C 

C  SCALE  SPECIFIC  VOL.  ANAMOLY  TO  NORMALLY  REPORTED  UNITS 
C 

SVAN>SVA*1 .0E«8 
V350P«V350P*PK 
C 

C  COMPUTE  DENSITY  ANAMOLY  WITH  RESPECT  TO  1000.0  KG/N**3 
C  1.  DENSITY  ANAMOLY  AT  35  (IPSS-78),  0  DEG.  C.  AND  0  DECIBARS 

C  2.  0R35P:  DENSITY  ANAMOLY  35  <IPSS-78),  0  DEG.  C.,  PRES.  VARIATION 

C  3.  DVAN:  DENSITY  ANAMOLY  VARIATIONS  INVOLVING  SPECIFIC  VOL.  ANAMOLY 

C 

C  CHECK  VALUE:  SIGMAs59.82037  KG/M**3  FOR  S>40  (IPSS-78}. 

C  T>40  DEG.  C.,  P0>10000  DECIBARS 

C 

DR35P«GAM/V350P 
0VAN»SVA/<  V350P*<  V350P+SVA ) ) 

S I  GMA-0R35OK)R35P  -DVAN 
RETURN 
END 
C 


^•••**«**«***«****«**«*«********«****«***«*«**«*********************^ 

C  FUNCTION:  THETA 

C  THIS  FUNCTION  COMPUTES  POTENTIAL  TEMPERATURE  AT  PR  USING 

C  BRYDEN  1973  POLYNOMIAL  FOR  ADIABATIC  LAPSE  RATE  AND 

C  RUNGE-KUTTA  4-TH  ORDER  INTEGRATION  ALGORITHM. 

C 

C  REFERENCE:  BRYDEN,  N.,  1973,  DEEP-SEA  RES.,  20,  PP  401-408 
C  FOFONOFF,  N.  1977,  DEEP-SEA  RES.,  24,  PP  489-491 

C 

C  UNITS:  PRESSURE  PO  DECIBARS 

C  TEMPERATURE  TO  DEG  CELSIUS  (IPTS-68) 

C  SALINITY  S  (IPSS-78) 

C  REFERENCE  PRS  PR  DECIBARS 

C  POTENTIAL  TMP  THETA  DEG  CELSIUS 

C 

C  CHECKVALUE:  TNETA«36. 89073  C,  S>40  (IPSS-7B),  T0«40  DEG.  C.. 

C  PO-10000  DECIBARS,  PR«0  DECIBARS 


C 

REAL  FUNCTION  THETA(S,TO,PO,PR) 

C 

C  SET  UP  INTERMEDIATE  TEMPERATURE  AND  PRESSURE  VARIABLES 
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P«P0 

T»T0 

H«PR-P 

XK»H*ATG(S,T,P) 

r=T+.5*XI( 

Q«XK 

P»P>.5*H 

XK»H*ATG<S,T,P) 

T=T*.29289322*(XK-Q) 

Q» , 5857854/ ‘XK* . 121320344*0 

XK=H*ATG(S,  - 

T*T+1.707106781‘'(XK-Q) 

Q=3.^1421i562*XK-4. 121320344*0 

P»P+.5*H 

XIC»H*ATG<S,T,P) 

THETA*T+(XK-2.*0)/6. 

RETURN 

END 


^M*********************************************************************** 

FUNCTION:  ATG  . 

ADIABATIC  TEMPERATURE  GRADIENT  DEG.  C.  PER  DECIBAR 


REFERENCE:  BRYDEN,  H..  1973  DEEP-SEA  RES..  20,  PP  401-408 


UNITS:  PRESSURE  P 

TEMPERATURE  T 

SALINITY  S 

ADIABATIC  ATG 


DECIBARS 

DEG  CELSIUS  <IPTS-68} 
(IPSS-78) 

DEG.  C/DECIBAR 


CHECKVALUE:  ATG>3.2S5976E-4  C/DBAR  FOR  Ss40  (IPSS-78) 

T>40  DEG.  C.,  P0>10000  DECIBARS 

I************************************************************************* 


REAL  FUNCTION  ATG(S,T,P) 


DS»S-35. 

ATG»(((-2.1687E-16*T*1.8676E-14)*T-4.6206E-13)*P 

*  ♦<(2.7759E-12*T-1.1351E-10)*DS*<<-5.4481E-14*T 

*  ♦8.733E-12)*T-6.7795E-10)*T+1.8741E-8))*P 

*  ♦<-4.2393E-8*T+1.8932E-6)*DS 

*  ♦{(6.6228E-10*T-6.836E-8)*T*8.5258E-6)*T»3.5803E-5 
RETURN 

END 


FUNCTION:  SVEL  -  COMPUTING  SOUND  VELOCITY 


r************  •••• 


REFERENCE:  SQIMD  SPEED  SEAUATER  CHEN  AND  MILLERO  1977,  JASA,  62, 
PP  1129  -  1135 


UNITS: 


PRESSURE 

PO 

DECIBARS 

TEMPERATURE 

T 

DEG.  CELSIUS  (IPTS-68) 

SALINITY 

S 

(IPSS-78) 

FOUND  SPEED 

SVEL 

METERS/SECOND 

CHECKVALUE:  SVEL  ■  1.731.995  M/S,  S«40  (IPSS-78), 
T  -  40  DEG  C 
P  ■  10000  OBAR 


REAL  FUNCTION  SVEL(S,T,P0) 

EOUIVALENCE  (A0,B0,C0),(A1,B1,C1),(A2,C2),(A3.C3) 
SCALE  PRESSURE  TO  BARS 
P-PO/10. 
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SR>SQRT(ABS(S)) 

S**a  TERM 

0»1.727E-3-7.9836E-6*P 
S**3/2  TERM 

B1«7.3«7E-5»1.m5E-7*T 

B0»-1.922E-2-4.42E-5*T 

B>B0>B1*P 

S**1  TERM 


A3«(-3.389E-13*T*6.649E-12)*T+1.100E-10 

A2»({7.988E-12*T-1.6002E-10>*T>9.1041E-9>*T-3.9064E-7 

A1»(((-2.0122E-10*T+1,0507E-8)*T-6.4a85E-8)*T-1.2580E-5>*T 

*  ♦9.4742E-5 

A0»(«-3.21E-8*T+2.006E-6)*T+7.164E-5)*T-1.262E-2)*T*1.389 
A»( (A3*P+A2)*P+A1 )*P>AO 

S**0  TERM 

C3«('2.3643E-12*T*3.8504E-10)*T-9.7729E-9 

C2«(«1.0405E-12*T-2.5335E-10)*T+2.5974E-8)*T-1.7107E-6)*T 

*  ♦3.1260E-5 

C1>«(-6.1185E-10*T+1.3621E-7)*T-8.1788E'6)*T*6.8982E-4)*T 

*  ♦.153563 

C0«< ( < <3. 1464E-9*T- 1 .47800E-6)*T+3.3420E-4)*T-5.80852E-2)*T 

*  ♦5.03711)*T41402.388 
C»((C3*P+C2)*P+C1 )*P+CO 


SOUND  SPEED 


SVEL«C+<A+B*SR*D*S)*S 

RETURN 

END 
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A0-(((-3.21E-8*T+2.006E-6)*T*7.16«E-5)*T-1.262E-2)*T+1.389 
A«(  (  A3*»>+A2)*P+A1  )*P*AO 


S**0  TERN 


C3»(-2.3643E-12*T*3.8504E-10)*T-9.7729E-9 

C2»(((1.(K05E-12*T-2.5335E-10)*T*2.5974E-8)*T-1.7107E-6)*T 

*  ♦3.12608-5 

C1*(((-6.1185E-10*T+1.3621E-7)*T-8.1788E-6)*T+6.8982E-4)*T 

*  ♦.153563 

C0a((«3.1464E-9*T-1.47800E-6)*T^3.3420E-4)*T-5.80852E-2)*T 

*  ♦5.03711)*T^1402.388 
C»((C3*P^C2)*P^C1 )*P^C0 

SOUND  SPEED 

SVEL=C^<A^B*SR-K>*S)*S 

RETURN 

END 
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Q***********************************************************************! 

C  SUBROUTINE:  CKFILE 

C  THIS  SUBROUTINE  CHECKS  EXISTENCE  AND  RECORD  SIZE  OF  A  GIVEN 

C  FILE  NAME 


Q**************************************************************************** 


C 

SUBROUT  I  HE  CKF I LE  ( I  UR .  I T  YPE ,  F I LNAM,  I UF ,  LUS,  LUSO,  F I LTYP,  NUPR ,  I  ST  ) 
CHARACTER*(*)  FILNAM 
LOGICAL  FEXIST 

IHTEGER*4  LUS(*),LUSO(*),FILTYP<*) 

C 

C 

NBPR>NUPR*4 

I NQUI RE( F I LE^F I LNAM, EXI ST-FEXIST ,RECL-NBYTES) 

GO  TO  (100,200), ITYPE 
C 

C  CHECK  FOR  A  FILE  WHICH  MUST  CURRENTLY  EXIST 
C 

100  IF(FEXIST)  THEN 

IF(NBYTES  .NE.  NBPR)  THEN 
URITE(IUR,110)  FILTYP(IUF) 

110  F0RMAT(2X, 'WRONG  FILE  IS  DESIGNATED  AS  '.AA,'  FILE') 

IST»'1 

ELSE 

LU-LUS(IUF) 

LUSO(IUF)>lU 
IFCUF  .EQ.  3)  THEN 

^ITE(IUR,120)  FILTYP(IUF),FILNAM 
120  FORMAT (2X, 'OPEN  EXISTING  ',A4,'  FILE:  ',A48) 

OPEN(UN I T>LU , F I LE-F I LNAM , STATUS* ' OLD ' , FORM* ' UNFORMATTED ' , 

•  ACCESS* 'DIRECT ' ,RECL*NWPR,READONLY) 

ELSE 

URITE(IUR,130)  FILTYP(IUF), FILNAM 
130  F0RMAT(2X, 'OPEN  EXISTING  ',A4,'  FILE:  ',A24) 

OPEN(UN  I T*LU , F I LE*F I LNAM , STATUS* ' OLD ' , FORM* ' UNFORMATTED ' , 

•  ACCESS* 'DIRECT',RECL*NUPR) 

ENOIF 

IST*0 

ENOIF 

ELSE 

IFdWF  .EQ.  3)  THEN 

URITE(IWR,140)  FILTYP(IUF), FILNAM 
140  FORMAT ( 2X, A4, '  FILE:  ',A48,'  DOES  NOT  EXIST') 

ELSE 

URITE(IUR,150)  FILTYP(IUF),FILNAM 
150  F0RMAT(2X,A4,'  FILE:  ',A24,'  DOES  NOT  EXIST') 

ENOIF 

IST*-1 

ENOIF 

RETURN 

C 

C  CHECK  FOR  A  FILE  WHICH  NAY  NOT  CURRENTLY  EXIST 
C  ALLOCATE  THE  FILE  IF  IT  DOES  NOT  EXIST 

C 

200  IF(FEXIST)  THEN 

IFLNBYTES  .NE.  NBPR)  THEN 
URITE(IUR,110)  FILTYP(IUF) 

IST*-1 

ELSE 

LU*LU$(IWF) 

LUSO(IUF)*LU 

URITE(IUR,130)  FILTYP(IUF), FILNAM 

OPEN(UN I T*LU, F I LE*F I LNAM, STATUS* 'OLD ' , FORM* 'UNFORMATTED ' , 

•  ACCESS*'OIRECT',RECL*NUPR) 

IST*0 

ENOIF 

ELSE 

LU«LUS(IWF) 
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LUSO(IWF)-LU 

URITE(IUR,220)  F1LTYP(IWF).FILNAM 
220  FOItMAT(2X, 'OPEM  A  NEW  '.AA,'  FILE:  •,A24) 

0PEN(UN1T-LU,FILE>FILNAM,STATUS>'NEU',F0RM>'UNF0RHATTED', 
*  ACCESS>'01RECT>,RECL«NUPR) 

IST»1 

ENOIF 

RETURN 

END 


C  SUBROUTINE:  CLSFIL 

C  THIS  SUBROUTINE  CLOSES  FILES  IF  THEY  ARE  CURRENTLY  OPEN 


^•••••***«*****««**********««*«*********««*M*************************l 

c 

SUBROUTINE  CLSFIL(LUSO,NXFS) 

INTEGER*4  LUSO(*) 

C 

C 

DO  10  I>2,MXFS 

IF(LUSO(I)  .GT.  0)  THEN 

CLOSE  (UNI  T>LUSO<  I ) ,  STATUS-  ‘KEEP  •  > 

LUSO(I)— 1 
ENOIF 
10  CONTINUE 
RETURN 
END 
C 

Q***-**********—«*************************************«*************i 


C  SUBROUTINE:  RUI 

C  THIS  SUBROUTINE  READS  USER'S  INPUT  AS  CHARACTER  STRING  AND 

C  THEN  CONVERTS  EACH  SUBSTRING  INTO  HOLLERITH,  INTEGER  OR 

C  FLOATING  VALUES  ACCORDINGLY 


C 

SUBROUTINE  RUI(IRO,IWR,IH.FA,IA,NVS) 

INTEGER*2  IBUF(3,40} 

INTEGER*4  BLANKS,PERI00,IH(*),IA(*) 

REAL  FA(*),XBUF(40) 

CHARACTER*80  CHRBUF,CA 
SAVE  IC,NCS,CHRBUF 
DATA  IC,NCS/0,0/ 

DATA  BLANKS/4H  / 

C 

C 

IF(NCS  .EQ.  0  .OR.  IC  .GT.  NCS)  THEN 
PERIOO-ICHARC.'} 

NINUS-ICNARC-') 

IZERO-ICHARCO'} 

NINE>ICHAR('9'} 

URITE(IUR,10) 

10  FORMATC  >',S) 

READ(IRO,20)  CHRBUF 
20  F0RMAT(A80) 

C 

C  CONVERT  ALPHABETIC  CHARACTERS  FROM  LOWER  CASE  TO  UPPER  CASE 
C 

DO  30  I>1,80 

IV«lCHAR(CHRnJF(I:I)) 

IF(IV.GE.97  .AND.  IV.LE.122)  THEN 
IV-IV-32 

CHRBUF(I:I)>CHAR(IV) 

ENDIF 

30  CONTINUE 

C 

C  FIND  ALL  SUBSTRINGS 
C 

IC-1 

NCS-0 
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lB-0 

tE*0 

00  50  I>1.80 

IF(CHRBUF(I:I).NE.'  •  .AND.  CHRBUF(1:I).NE. ' , • )  THEN 
IF(1B  .EQ.  0)  IB>I 
lE-I 
ELSE 

IF(IB  .GT.  0)  THEN 
NCS«NCS'»1 
IBUF(1,NCS)>IB 
IBUF(2,NCS)>IE 
IBUF(3,NCS)>0 
XBUF(NCS)«0. 

IB«0 

IE>0 

ENOIF 

ENOIF 

50  CONTINUE 

IF(1B  .GT.  0)  THEN 
NCS-NCS«1 
IBUF(1,NCS)>IB 
1BUF(2,NCS)>IE 
IBUF(3,NCS)-0 
)(BUF(NCS)>0. 

ENOIF 

CONVERT  NUMERIC  SUBSTRINGS  INTO  FLOATING-POINT  VALIKS 

DO  90  I>1,NCS 
IB>IBUF(1,I) 

IE-IBUF(2,I) 

IV>ICHAR(CHRBUF(IB:IB)) 

IF(IV  .EQ.  MINUS)  THEN 
IB«IB-»1 
ISIGNa-1 
ELSE 

ISIGNal 
ENOIF 
XF1«0. 

XF2>0. 

IFLAG«0 
NDGT$«0 
DO  60  J-IB,IE 

IVaICHAR(CHRBUF(J:J)) 

IF«IV.LT.IZERO  .OR.  IV.GT.NINE)  .AM). 

*  IV.NE. PERIOD)  GO  TO  90 

IF(1V  .EQ.  PERIOD)  THEN 
I  FLAG-1 
ELSE 

I F( I  FLAG  .EQ.  0)  THEN 
XF1-XF1*10.><IV-IZERO) 

ELSE 

XF2-XF2*10.4(IV-IZERO) 

NOGTS-NOGTS-^1 
ENOIF 
ENOIF 

60  CONTINUE 

IBUF(3,I)«1 

XBUF(I)-ISIGN*(XFU(XF2/(10^NDGTS))) 

90  CONTINUE 
ENOIF 
C 

C  INITIALIZE  RETURNED  ARGUMENTS 
C  IN:  ARRAY  STORED  HOLLERITH  VALUES 
C  lA:  ARRAY  STORED  INTEGER  VALUES 
C  FA:  ARRAY  STORED  FLOATING-POINT  VALUES 
C  NVS:  NUMBER  OF  VALUES  RETURNED  IN  IA,FA  ARRAYS 
C 

DO  100  1-1,20 
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IH(1)>BLANKS 
100  CONTINUE 

00  110  I«1,10 
IA(I)>0 
FA(I)«0. 

110  CONTINUE 
NVSaO 
C 

C  RETURN  PROPER  HOLLERITH  AND  NUNERIC  VALUES 
C 

IF(NCS  .GT.  0)  THEN 

IF(IBUF(3,IC)  .EO.  0)  THEN 
IB>IBUF(1,IC) 

IE«IBUF(2,IC) 

CA(1:80)s'  ' 

I>IE-IB-^1 

CA(1:I)>CHRBUF(IB:IE) 

REA0(CA,120)  (IH(I).Is1,20) 

120  FORMAT(20A4) 

IC«IC+1 

ENOIF 

C 

C  RETURN  ALL  NUNERIC  VALUES  BEFORE  NEXT  HOLLERITH  STRING  IS  ENCOUNTERED 
C 

DO  130  I>IC,NCS 

IF(IBUF(3,I)  .EQ.  0)  GO  TO  140 

NVS-NVS^I 

FA(NVS)«XBUF(I) 

IA(NVS)aFA(NVS) 

130  CONTINUE 

140  IC>I 

ENOIF 
RETURN 
ENO 
C 

QMMMaMM************************************  ••*•*****••••*•*••**•**•• 

C  SUBROUTINE:  OLXY 

C  THIS  SUBROUTINE  DETERMINES  X,Y  COORDINATES  OF  POINTS 

C  BETWEEN  TWO  GIVEN  ENO  POINTS 

c 

SUBROUTINE  0LXr( 1X1 , I Y1 , 1X2, I Y2,NPTS,NXVS. IXS, I YS) 

INTEGER*4  IXS<*), IYS(*) 

C 

C 

IFdYl  .EQ.  IY2)  THEN 
NINX>MIN0(IX1.IX2) 

NAXX-MAX0(IX1,IX2) 

NPTS>0 

DO  10  I^MINX.MAXX 
NPTS»NPTS-»1 

IF(NPTS  .GT.  MXVS)  RETURN 
IXS(NPTS)>I 
IYS(NPTS)«IY1 
10  CONTINUE 
ELSE 

IFdXI  .EQ.  1X2)  THEN 
NINy>MIN0dYl,IY2) 

NAXYaMAX0dY1,IY2) 

NPTS-0 

DO  20  I>MINY,MAXY 
NPTS-NPTS+1 

IF(NPTS  .GT.  NXVS)  RETURN 
IXS(NPTS)-IX1 
IYS(NPTS)>I 
20  CONTINUE 

ELSE 

yY«IY2*IY1 

XX-IX2-IX1 
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SLOPE«YY/XX 

NINY>MIN0(IY1,IY2) 

MAXY>MAX0(IY1,1Y2) 

IF(SLOPE  .EQ.  -1.  .OR.  SLOPE. E0.1.)  THEN 
NPTS>0 

00  30  I>MINY,MAXY 
Y-I-IY1 

IX*Y/SL0PE+IX1+.5 

lllPTS»XPTS+1 

IF<NPTS  .GT.  MXVS)  RETURN 

IXS(NPTS)>1X 

IYS(NPTS)«I 

30  CONTINUE 

ELSE 

M1NX>>HIN0(1X1,IX2) 

NAXX««MX0(IX1,IX2) 

NPTS«1 

IF(NINY  .EQ.  IY1)  THEN 
IXS(NPTS)>IX1 
IYS(HPTS)«IY1 
ELSE 

IXS(NPTS)-1X2 

1YS(NPTS)>1Y2 

ENOIF 

DO  90  I-MINY.NAXY 
Y«I-IY1 
X»Y/SL0PE*IX1 
IX«(1./SL0PE)+X+.5 
1X-X+.5 
JX-IXS(HPTS) 

IF(IX  .GT.  JX)  THEN 
00  40  J«JX.IX 

1F(J.NE.IXS(HPTS)  .OR.  I.NE.IYS(NPTS))  THEN 
NPTSbNPTS«1 

IF(NPTS  .GT.  MXVS)  RETURN 
IXS(NPTS>*J 
lYS(NPTS)al 
ENOIF 

40  CONTINUE 

ELSE 

DO  SO  J3JX,IX,-1 

IF(J.NE.IXS(NPTS}  .OR.  I.NE.IYS(NPTS))  THEN 
HPTS»NPTS-*’1 

IF(NPTS  .GT.  MXVS)  RETURN 
IXS(NPTS)«J 
IYS(MPTS)»I 
ENOIF 

SO  CONTINUE 

ENOIF 

90  CONTINUE 

ENOIF 
ENOIF 
ENOIF 
RETURN 
ENO 


C 

C' 


SUBROUTINE:  DATIME 

THIS  SUBROUTINE  CALLS  SYSTEM  OEPENOANT  ROUTINES,  IDATE  ANO 
TIME,  TO  GET  CURRENT  DATE  ANO  TIME  OF  DAT 


SUBROUTINE  OATINE(OATE,tTINE,ISEC) 

INTEGERS  IMDY(3),IHMS(3),ITENP(2),0ATE(*),ITIME(*) 
EQUIVALENCE  (IMDY(1),IHMS(1)) 

C 

C 

CALL  IDATE(IMDY(1),IMDT(2).INDY(3)) 
ENCQ0E(8,10,ITEMP)  INDY 


S8 
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10  FOmMT(I2.2.'/M2.2,'/',I2.2) 

0ATE(1)>ITEMf>(1) 

DATE(2)>ITEMP(2) 

CALL  TINEdTEMP) 

ITIME(1)»ITEHI»(1) 

ITIME(2)>ITENP(2} 

CONVERT  TI»«  INTO  SECONDS 

DECOOE(8,20,ITEHP)  INNS 
20  FORMAT! 12, IX, 12. 1X, 12) 

1 SEC> I HMS ( 1 )*360O»  I  HNS ( 2 )*60»  I  HMS( 3 ) 

RETURN 

END 
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OOO  OOO  ooo 


FV  PMOMN  LISTIIK 


c 

Q******««******««*****M**««*****«**************«**«********************I 

C  PROGRAM  NAME:  FSP  -  PLOT  SFF,  SVF,  TF  OR  SF  FILE  OUTPUT  BY  PROGRAM  FSM 
C  DATE:  AUGUST  7.  1990 
C  PROGRAMMER:  TIGER  CHENG  (SVERDRUP) 

Q***********************************************************************! 

c 

PROGRAM  FSP 
PARAMETER  (NWFN-6) 

PARAMETER  (N0IR3>6) 

PARAMETER  (MXFS>6) 

PARAMETER  (MXPARS>6) 

PARAMETER  (NBPRCF-400,NWPRCF>NBPRCF/4) 

PARAMETER  (NXR0WS>>480,MXCOLS>640) 

PARAMETER  (MXVS>MXROUS'HO(COLS) 

PARAMETER  (MXUWS-90000) 

INTEGERS  BLANKS, IH(20),IA(10),IHFN(1S). 

*  F|LTYP(NXFS).LUS(MXFS),LUSO<M)(FS),IOIRS(NDIRS), 

*  IXS(MXVS),IYS(MXVS).INOEX(MXVS), 

*  IPAR(MXPARS).DEFPAR(MXPARS), 

*  IBUF(NWPRCF),JBUF(NWPRCF) 

REAL  FA(10),PBUF(MXVS*MXVS),VBUF(MXVS) 

CHARACTER*24  CFN.PFN 
CHARACTER*60  CHFN 

EQUIVALENCE  (IV,FV) 

COMMON  UORK(MXUUS) 

DATA  I RD/S/ 

DATA  I UR/6/ 

DATA  BLANKS/4H  / 

DATA  FtLTYP/4HCF  ,4HNMF  ,4HSFF  ,4HSVF  ,4HTF  .4HSF  / 

DATA  LUS/MXFS*4/ 

DATA  LUSO/MXFS*-1/ 

DATA  IDCF/56789/ 

DATA  IDIRS/4HLD  ,4HIN  ,4HSP  ,4HPLOT,4HSF  ,4HEND  / 

C 

C 

URITEdUR.IO) 

10  FORMAT(2X, 'FRONT  SIMULATION  PLOTTING  PROGRAM') 

WRITE(IUR,20) 

20  FORMAT (2X, 'ENTER  CONTROL  FILE  (CF)  NAME') 

CALL  RUI(IRD,IUR,IH,FA,IA,NVS) 

IF(IH(1)  .EQ.  BLANKS)  STOP 
URITE(CFN,30)  (IH(I ), I«1,NWFN) 

30  F0RMAT(6A4) 

CHECK  EXISTENCE  OF  CONTROL  FILE 

CALL  CKFILE(IUR,1,CFN,1,LUS,LUSO,FILTYP,NUPRCF,tST) 

IFdST  .NE.  0)  STOP 

READ(LUS(1),REC>1)  (IBUFd ). I«1,NUPRCF) 

IFdBUF(l)  .NE.  IDCF)  THEN 
URITEdUR,40} 

I  FORMAT(2X, 'URONG  CONTROL  FILE  IS  USED') 

GO  TO  900 
ENDIF 

READ  IN  EXTERNAL  FILE  NAMES  STORED  IN  THE  CONTROL  FILE 

REAO(LUS(1),REC>2)  (JBUFd ), I>1 .NUPRCF) 

CLOSE (UN I T«LUS( 1 ) , STATUS- ' KEEP ' ) 

GET  FSM  PROCSSING  PARAMETERS  dZ,NZS,MPTS) 

IX1-IBUF(41) 

IT1-IBUF(42) 

IX2-IBUF(43> 

IY2>IIUF(44) 
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CAUL  OLXY( 1X1 , I Y1 , 1X2, I Y2,HPTS,MXVS, IXS, I YS) 

IZ-IBUF(49) 

NZS-IBUF(SO) 

C 

C  USER  SELECTS  A  FILE  TO  PLOT 
C 

50  CALL  SELECF(IRD.IUR,FILTYP,MXFS.JBUF.NUFN,IUF,1H,FA,IA) 
IFCIWF  .EQ.  0}  GO  TO  900 
C 

C  SET  PARAMETERS  TO  DEFAULT  VALUES  BASED  UPON  THE  SELECTED  FILE 
C 

FV«U. 

DEFPAR(1)3lV 

FV»11. 

DEFPAR(2)>IV 
DEFPAR(3)>1 
DEFPAR(5)>1 
IFdUF  .EQ.  2)  THEN 
NWPR>MXROWS 
DEFPAR(4)-MXR0US 
DEFPAR(6)>MXC0LS 
ELSE 

NUPR-NZS 

DEFPAR(4)*NZS 

DEFPAR(6)>MPTS 

ENDIF 

C 

C  INITIALIZE  PARAMETERS  TO  DEFAULT  VALUES 
C 

DO  60  I^I.MXPARS 
IPAR(I)-OEFPAR(I) 

60  CONTINUE 
C 

C  OPEN  SELECTED  FILE 
C 

IfaUSO(lUf)  .EO.  -1}  THEN 
CALL  CLSFIL(LUSO.MXFS) 

IW»<IWF-2)*10*21 

URITE(PFN,30)  ( JBUFd ), I«IW,IWtNWFN-1 ) 

CALL  CKFILE( lUR. 1 .PFN, IWF.LUS.LUSO, FILTYP.NUPR, 1ST) 
IFdST  .NE.  0)  STOP 
C 

C  ENCODE  FILE  NAME  TO  BE  USED  FOR  PLOT  HEADING 
C 

CALL  OATIMEdH.IA.ISEC) 

ENC0OE(60,70,IHFN)  FILTYPdUF\(JBUFd),I»IU.IU«NWFN-1), 
*  IHd),IH(2),IAd),IA(2) 

70  F0RMAT(A4,' FILENAME;  ',6A4,'  ',2A4,'  '.ZAA.'S') 

ENOIF 
IGO-0 
GO  TO  300 
C 
C 

100  URITEdW,120) 

120  FORMAT (2X, 'ENTER  PROGRAM  MAIN  DIRECTIVE  NAME') 

CALL  RUIdRO,IUR,IH,FA,IA,NVS) 

DO  130  IOO>1,NOIRS 

IFCIHd)  .EQ.  IDIRSdGO))  GO  TO  190 
130  CONTINUE 

URITEdUR,140) 

140  F0RNAT(2X.' INVALID  PROGRAM  MAIN  DIRECTIVE') 

GO  TO  100 
C 
C 

190  GO  TO  (200,300,400,500,50,900), IGO 
C 

C  LD  -  LIST  PROGRAM  DIRECTIVES 
C 

200  HRITEdMI,210) 
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210  FORMAK 

*2X,'L0  -  LIST  PROGRAH  DIRECTIVES',/, 

*2X,‘IH  -  INITIALIZE  PLOTTING  PARAMETERS',/, 

•2X,'SP  -  SET  PLOTTING  PARAMETERS',/, 

*2X,'PLOT  -  GENERATE  A  PLOT  FILE  (POPFIL.OAT)',/, 

*2X,'SF  -  RETURN  TO  FILE  SELECTION  MODE',/, 

•2X,'ENO  •  END  THE  PROGRAM') 

GO  TO  100 
C 

C  IN  -  INITIALIZE  PLOTTING  PARAMETERS 
C  IPAR(I)  >  PAGE  X 

C  IPAR(2)  »  PAGE  Y 

C  IPAR(3)  -  INITIAL  COLUMN  TO  PLOT  (Y  AXIS) 

C  IPAR(4)  >  LAST  COLUMN  TO  PLOT  (Y  AXIS) 

C  IPAR(5)  -  INITIAL  ROW  TO  PLOT  <X  AXIS) 

C  IPAR(6)  >  LAST  ROW  TO  PLOT  (X  AXIS) 

C 

300  DO  310  I»1,MXPARS 

IPAR(I)-OEFPAR(I) 

310  CONTINUE 
GO  TO  100 
C 

C  SP  -  SET  PARAMETERS 
C 

400  CALL  SETPAR(IRO,IUR,IPAR,DEFPAR,FILTYP<IWF),IH,FA,IA,IST) 
IFdST  .EG.  -1)  GO  TO  900 
GO  TO  100 
C 

C  PLOT 
C 

500  IV-tPAR(l) 

UIO-FV 

IV-IPAR(2) 

HT-FV 

IY>IPAR(3) 

LY»IPAR<4) 

IX>IPAR(5) 

LX-IPAR(6) 

IX$IZE-LX-IX«1 

IYSIZE»LY-IY*1 

XI>IX 

XL-LX 

I«<LX*IX+1)/10 

XD-I 

IFdWF  .EO.  2)  THEN 
YI-IY 
YL»LY 

I»<LY-IY>1)/10 

ELSE 

YI»dY-1)*IZ 

YL»<LY-1)*IZ 

IY1»YI 

IY2-YL 

I»dY1-tY2)/10 

ENDIF 

YO-I 

C 

C  READ  IN  DATA  FROM  SELECTED  FILE 
C 

MtITEdUR,510)  FILTYPTIWF) 

510  F0RMAT(2X, 'READING  IN  ',A4,'  FILE') 
INOEXdXSIZE)*IYSIZE*lXStZE 
DO  512  I>IXSIZE-1,1,-1 
INDEXd)>INDEXd>1)-1 
512  CONTINUE 

DO  520  l■IX,LX 

REAO(LUSdUF),REC>I)  (VIUF(J),J>1,NUPR) 
IXYW>INDEXd-IXd) 

00  514  J>IY,LY 
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PBUF(IXYW)>VBUF(J) 

1XYU>IXYW-1XSIZE 
514  CONTINUE 
520  CONTINUE 
C 

C  FIND  MININUM  ANO  NAXINUM  VALUES  WITHIN  THE  AREA  OF  INTEREST 
C 

VMIN>PBUF(1) 

VMAX«VMIN 

DO  530  I«1,IN0EX(IXSIZE) 

IF(PBUF<I)  .LT.  VMIN)  THEN 
VMIN>PBUF(I) 

ELSE 

IF(PBUF(I)  .GT.  VMAX)  VMAXaPBUFd) 

ENDIF 
530  CONTINUE 
C 

C  USER  DEFINES  INCREMENT  FOR  GENERATING  CONTOUR  LINES 
C 

WRITE(IUR,540)  VMIN, VMAX 

540  FORMAT(2X,>MIN  I  MAX  VALUES  FOUND  WITHIN  THE  AREA  TO  BE 
*  'PLOTTED:  '.FIO.S,',  ',F10.5) 

WRITE(IWR,542) 

542  FORMAT (2X, 'ENTER  INCREMENT  VALUE  FOR  GENERATING  CONTOUR  LINES') 
CALL  RUI(IRO,IWR,IH,FA,IA,NVS) 

IF(FA<1)  .LE.  0.)  GO  TO  100 
VINCR«FA<1) 

C 

C  SET  UP  PLOT 
C 

CALL  COMPRS 
CALL  PAGE(WIO,HT) 

W-WIO-2. 

H-HT-2. 

CALL  AREA2D(W,H) 

IFdWF  .EQ.  2)  THEN 

CALL  XNAME('<-X  POSITION  ->$',100) 

CALL  YNAME<'<-Y  POSITION  ->$',100) 

ELSE 

CALL  XNAME('<-  ACROSS  THE  FRONT  ->$',100) 

CALL  YNAME('<-  DEPTH  ->$',100) 

ENOIF 

CALL  HEAOINdHFN, 100, 1.5,1) 

CALL  GRAF(XI,XO,XL,YL,YD,YI) 

CALL  BCOMON(MXWWS) 

C 

C  MAKE  CONTOURS 
C 

WRITEdWR,550) 

550  FORMAT (2X, 'GENERATING  CONTOUR  LINES') 

CALL  C0NMAK(P8UF,IXSIZE,IYSIZE,VINCR) 

C 

C  DEFINE  CONTOUR  LINES  CHARACTERISTICS 
C 

CALL  CONLIN(0, 'SOLID', 'LABELS', 1,10) 

CALL  C0NLIN<1, 'DASH', 'NOIABELS', 1,8) 

C 

C  DRAW  CONTOUR  LINES 
C 

NRITEdWR,580) 

560  F0RMAT(2X, 'DRAWING  CONTOUR  LINES') 

CALL  C0NTUR(2, 'LABELS', 'DRAW') 

CALL  ENOPL(O) 

CALL  DONEPL 
GO  TO  100 
C 

C  END 
C 

900  CALL  CLSFIL(LUSO,NXFS) 
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STOP 

END 


C 

C  SUBROUTINE:  SELECF 

C  THIS  SUBROUTINE  ALLOWS  THE  USER  TL  SELECT  A  FILE  TO  PLOT 

C*************************************-***********.********************* 

C 

SUBROUTINE  SELECF( IRO, lUR.FILTYP.MXFS. JBUF,NUFN, lUF, IH,FA, lA) 
INTEGER*4  BLANKS, EXIT, END, FILTYP<*),J8UF(*),IH(*),IA{*) 

REAL  FA(*) 

DATA  BLANKS/4H  / 

DATA  EXIT/4HEX  / 

DATA  END/4HEND  / 

C 

C 

10  IFS«0 

IWF>0 

URITE(IUR,20) 

20  F0RFMT(2X, 'EXTERNAL  FILES  STORED  IN  THE  CONTROL  FILE'} 

DO  100  I>2,MXFS 
IW-(I-2)*10+21 

WRITE! IWR, 30)  FILTYP(n,(JBUF(J),J«IW.IW«NWFN>3) 

30  FORMAT (2X,A4,'»  ' ,6A4,T33, 'LAST  WRITTEN  TIME:  ',2A4,'  ', 

*  2A4) 

IF(JBUF(I)  .NE.  BLANKS)  IFS-IFS>1 
100  CONTINUE 

WRITE(IWR,110)  EXIT 

110  FORMAT (2X,A4,'«  EXIT  FROM  FILE  SELECTION  MODE') 

WRITE! IWR, 120)  ENO 

120  FORMAT!2X,A4.'*  ENO  THE  PROGRAM') 

C 

C 

IF!IFS  .EQ.  0)  THEN 
WRITE! IWR, 130) 

130  F0RMAT!2X, 'NO  EXTERNAL  FILE  NAMES  STORED  IN  THE  CONTROL  FILE') 
RETURN 
ENOIF 
C 
C 

WRITE! IWR, 150) 

ISO  FORMAT !2X, 'SELECT  A  FILE  TO  PLOT') 

CALL  RUI!IRO,IWR,IH,FA,IA,NVS) 

DO  200  IWF*2,MXFS 

IF!IH!1)  .EQ.FILTYP!IWF})  GO  TO  300 
200  CONTINUE 

IF!IN!1)  .EQ.  EXIT)  RETURN 
IF!IH!1)  .EQ.  ENO)  THEN 
IWF>0 
RETURN 
ENOIF 

WRITE!IWR,210) 

210  F0RMAT!2X,' INVALID  FILE  SELECTION') 

GO  TO  10 
C 
C 

300  IW»!IWF-2)*10*21 

IF!JBUF!IW)  .EQ.  BLANKS)  THEN 
WRITE! IWR, 210) 

GO  TO  10 
ENDIF 
RETURN 
END 


C 


C  SUBROUTINE:  SETPAR 

C  THIS  SUBROUTINE  SETS  PLOTTING  PARAMETERS 


C 


64 


c 

c 


10 

20 


30 


C 

C 

SO 

60 


70 

80 


SUBROUTINE  SETPARCIRD, lUR, IPAR.DEFPAR, IFTYPE, IH,FA,IA. 1ST) 
PARAMETER  (NOIRS-IO) 

IMTEGER*4  ID!RS<NDIRS), IPAR(*),DEFPAR(*). 1H(*), IA(*) 

REAL  FA(*) 

EQUIVALENCE  (IV,FV) 

DATA  IDIRS/4HL0  ,4HLP  ,4HEX  ,4HEND  .4HUI0  .4HHT  .4HIC  , 
'  4HLC  ,4H1R  ,4HLR  / 


IV=0EFPAR(1) 

WID=FV 

IV^EFPAR(2) 

HT=FV 

1C3DEFPAR(3) 

LC*0EFPAR(4) 

IR4EFPAR(5) 

LR»0EFPAR(6) 

IV>IPAR(1) 

WIDTHsFV 

IV»IPAR(2) 

HEIGHT-FV 

URITE(IUR,20)  IDIRS(1),IDIRS(2),IDIRS(3).ID1RS(4). 
•  I0IRS(S),UID,I0IRS(6),HT 


FORMAT ( 

*2X,A4,'  *  LIST  SP  SUBOIRECTIVES',/, 

*2X,A4,'  «  LIST  PLOTTING  PARAMETERS',/, 

•2X,A4,'  ■  EXIT  FROM  SP  DIRECTIVE',/, 

*2X,A4,'  *  END  THE  PROGRAM',/, 

*2X, '*•***  AVAILABLE  PLOTTING  PARAMETERS  *****',/, 
*2X,A4,'  >  WIDTH  OF  PLOT  (MAXIMUM  ',FS.2,'  INCHES)',/, 
*2X,A4,'  »  HEIGHT  OF  PLOT  (MAXIMUM  ',F5.2,'  INCHES)') 
UR1TE(IWR,30)  IDIRS(7),IFTYPE,IC,I0IRS(8),1FTYPE,LC, 

*  I0IRS(9),IFTYPE,IR,I0IRS(10),IFTYPE,LR 


FORMAT ( 

*2X,A4,'  3  initial  COLUMN  OF  ',A4,' 

*  '(MINIMUM  ',14,')',/, 

*2X,A4,'  *  LAST  COLUMN  OF  ',A4,' 

*  '(MAXIMUM  ',14,')',/, 

»2X,A4,'  »  INITIAL  ROW  OF  ',A4,' 

*  '(MINIMUM  ',14,')',/, 

*2X,A4,'  »  LAST  ROW  OF  ',A4,' 

*  '(MAXIMUM  ',14,')') 


FILE  TO  BE  PLOTTED  ', 
FILE  TO  BE  PLOTTED  ', 
FILE  TO  BE  PLOTTED  ', 
FILE  TO  BE  PLOTTED  ', 


URITE(IWR,60) 

FORMAT (2X, 'ENTER  SP  SUBOIRECTIVE  NAME') 
CALL  RUI(1R0,IWR,IH,FA,IA,NVS) 

DO  70  IGO-1,NOIRS 

IF(IH(1)  .EQ.  lOIRS(IGO))  GO  TO  100 
CONTINUE 
URITEdWR  80) 

F0RMAT(2xi' INVALID  SP  SUBDIRECTIVE') 

GO  TO  so 


C 

C 

100  IF((IGO.GT.4  .AND.  IGO.LE.NOIRS)  .ANO.  NVS.EQ.O)  THEN 
URITEdWR, 110)  IDIRSdGO) 

110  FORMAT(2X, 'ENTER  VALUE  FOR  PARAMETER  ',A4) 

CALL  RUI(IRD,IWR,>H,FA,1A,NVS) 

ENOIF 

GO  TO  (10,20O,90O,900,300,320,400,400,S00,S00),IGO 
C 

C  LP 
C 

200  URITEdWR, 210)  IDIRS(S), WIDTH, I0IRS(6), HEIGHT, 

*  IDIRS(7),IPAR(3),ID1RS(8),IPAR(4). 

*  IDIRS(9),IPAR(S),IDIRS(10),IPAR(6) 

210  FORMAT( 

*2X,A4,'  «  ',FS.2,T31,A4,'  »  ',FS.2,/, 
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*2X,A4,'  *  M4,T31,A4.'  =  '.lA,/. 

*2X,A4, ■  =  ',I4,T31,A4,'  =  '.14) 

GO  TO  so 
C 

C  UID 
C 

300  IF(FA(1).LT.S.  .Oft.  FA(1).GT.UI0}  THEN 
UftITE(IUft,312)  IDIftS(IGO),UID 

312  FOftHAT<2X, 'PARAMETER  ',A4, '  CANNOT  BE  <  5.00  Oft  >  •.F5.2) 
ELSE 

FV=FA(1) 

IPAR(IGO-4}sIV 
WI0TH=:FV 
END  IF 
GO  TO  so 
C 

C  HT 
C 

320  IF(FA(1).LT.5  .OR.  FA(I).GT.HT)  THEN 

URITE(IWR,312)  IDIRS<1G0),HT 
ELSE 

FV»FA(1) 

1PAR(1G0-4)>IV 
HEIGHT^FV 
ENOIF 
GO  TO  SO 
C 

C  IC.LC 
C 

400  IF(IA(1).LT.IC  .OR.  lA(l).GT.LC)  THEN 
URITE(1UR.412)  lOIRS(lGO), IC.LC 

412  FORMAT <2X, 'PARAMETER  '.A4,'  CANNOT  BE  <  '.14. 'OR  >  *.14) 

ELSE 

IPAR(IG0-4)-IA(1) 

ENOIF 
GO  TO  50 
C 

C  IR.LR 
C 

SOO  IF(IA(1).LT.IR  .OR.  lA(l).GT.LR)  THEN 

URITE(IUR,412)  IDIRS<IGO).OEFPAR(6).DEFPAR(7) 

ELSE 

IPAR(IG0-4)>IA(1) 

ENOIF 
GO  TO  SO 
C 

C  EX, END 
C 

900  IF(IGO  .EQ.  3)  THEN 

IF(IPAR(3)  .GT.  IPAR(4))  THEN 

URITE(IUR,910)  I0IRS(8),I0IRS<7) 

910  FORMAT (2X, 'PARAMETER  ',A4,'  IS  SMALLER  THAN  PARAMETER  ', 

*  A4,'-  RESET  THEN  PLEASE') 

GO  TO  50 
ELSE 

IF(IPAR(5)  .GT.  IPAR(6))  THEN 

URITE(IM(,910)  IDIRS(10),IDIRS(9) 

GO  TO  SO 
ENOIF 
ENOIF 
IST«0 
ELSE 

IST-1 

ENOIF 

RETURN 

END 
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